1
0
forked from GitHub/gf-core

added mkAbs and unAbs in the Haskell binding

This commit is contained in:
krasimir
2017-01-26 10:04:42 +00:00
parent a06e0b6b6f
commit be43d5dfdc
3 changed files with 42 additions and 4 deletions

View File

@@ -30,7 +30,8 @@ module PGF2 (-- * PGF
-- ** Functions
Fun,functions, functionsByCat, functionType, hasLinearization,
-- ** Expressions
Expr,showExpr,readExpr,mkApp,unApp,mkStr,unStr,mkInt,unInt,mkFloat,unFloat,
Expr,showExpr,readExpr,
mkAbs,unAbs,mkApp,unApp,mkStr,unStr,mkInt,unInt,mkFloat,unFloat,
-- ** Types
Type(..), Hypo, BindType(..), startCat, showType,

View File

@@ -33,6 +33,37 @@ data Expr = forall a . Expr {expr :: PgfExpr, exprMaster :: a}
instance Show Expr where
show = showExpr []
-- | Constructs an expression by lambda abstraction
mkAbs :: BindType -> CId -> Expr -> Expr
mkAbs bind_type var (Expr body master) =
unsafePerformIO $ do
exprPl <- gu_new_pool
cvar <- newUtf8CString var exprPl
c_expr <- pgf_expr_abs cbind_type cvar body exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (exprFPl,body))
where
cbind_type =
case bind_type of
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
-- | Decomposes an expression into an abstraction and a body
unAbs :: Expr -> Maybe (BindType, CId, Expr)
unAbs (Expr expr master) =
unsafePerformIO $ do
c_abs <- pgf_expr_unabs expr
if c_abs == nullPtr
then return Nothing
else do bt <- fmap toBindType ((#peek PgfExprAbs, bind_type) c_abs)
var <- (#peek PgfExprAbs, id) c_abs >>= peekUtf8CString
c_body <- (#peek PgfExprAbs, body) c_abs
return (Just (bt, var, Expr c_body master))
where
toBindType :: CInt -> BindType
toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
-- | Constructs an expression by applying a function to a list of expressions
mkApp :: Fun -> [Expr] -> Expr
mkApp fun args =

View File

@@ -257,6 +257,15 @@ foreign import ccall "pgf/pgf.h pgf_fullform_get_analyses"
foreign import ccall "pgf/pgf.h pgf_expr_apply"
pgf_expr_apply :: Ptr PgfApplication -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_unapply"
pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication)
foreign import ccall "pgf/pgf.h pgf_expr_abs"
pgf_expr_abs :: CInt -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_unabs"
pgf_expr_unabs :: PgfExpr -> IO (Ptr a)
foreign import ccall "pgf/pgf.h pgf_expr_string"
pgf_expr_string :: CString -> Ptr GuPool -> IO PgfExpr
@@ -269,9 +278,6 @@ foreign import ccall "pgf/pgf.h pgf_expr_float"
foreign import ccall "pgf/pgf.h pgf_expr_unlit"
pgf_expr_unlit :: PgfExpr -> CInt -> IO (Ptr a)
foreign import ccall "pgf/pgf.h pgf_expr_unapply"
pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication)
foreign import ccall "pgf/expr.h pgf_expr_arity"
pgf_expr_arity :: PgfExpr -> IO CInt