From be43d5dfdc777995d237e224da7f627426774527 Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Thu, 26 Jan 2017 10:04:42 +0000
Subject: added mkAbs and unAbs in the Haskell binding

---
 src/runtime/haskell-bind/PGF2/Expr.hsc | 31 +++++++++++++++++++++++++++++++
 1 file changed, 31 insertions(+)

(limited to 'src/runtime/haskell-bind/PGF2/Expr.hsc')

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 =
-- 
cgit v1.2.3