API for computing the Haskell binding

2 files changed, 21 insertions, 0 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index e87bc901b..0c976db37 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -45,6 +45,9 @@ module PGF2 (-- * PGF
              -- ** Type checking
              checkExpr, inferExpr, checkType,
 
+             -- ** Computing
+             compute,
+
              -- * Concrete syntax
              ConcName,Concr,languages,
              -- ** Linearization
@@ -279,6 +282,22 @@ checkType (PGF p _) (Type c_ty _) =
                 then return (Left msg)
                 else throwIO (PGFError msg)
 
+compute :: PGF -> Expr -> Expr
+compute (PGF p _) (Expr c_expr _) =
+  unsafePerformIO $
+  withGuPool $ \tmpPl -> do
+    exn <- gu_new_exn tmpPl
+    exprPl <- gu_new_pool
+    c_expr <- pgf_compute p c_expr exn tmpPl exprPl
+    status <- gu_exn_is_raised exn
+    if not status
+      then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
+              return (Expr c_expr exprFPl)
+      else do c_msg <- (#peek GuExn, data.data) exn
+              msg <- peekUtf8CString c_msg
+              gu_pool_free exprPl
+              throwIO (PGFError msg)
+
 -----------------------------------------------------------------------------
 -- Graphviz
 
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 5ae2ced06..35aa7fa84 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -301,6 +301,8 @@ foreign import ccall "pgf/expr.h pgf_infer_expr"
 foreign import ccall "pgf/expr.h pgf_check_type"
   pgf_check_type :: Ptr PgfPGF -> Ptr PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
 
+foreign import ccall "pgf/expr.h pgf_compute"
+  pgf_compute :: Ptr PgfPGF -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO PgfExpr
 
 foreign import ccall "pgf/expr.h pgf_print_expr"
   pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()