diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index c27643f84..cdafb6eb9 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -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, diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index e6f949a45..9fd0494bd 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -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 = diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 9e51bb34b..0e5ba250c 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -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