added loadConcr/unloadConcr to the Haskell binding. This exposes an API for loading grammars compiled with -split-pgf

2 files changed, 40 insertions, 4 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index f6bfce25e..35631cd4c 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -14,6 +14,7 @@
 
 module PGF2 (-- * PGF
              PGF,readPGF,abstractName,startCat,
+             loadConcr,unloadConcr,
              -- * Concrete syntax
              Concr,languages,parse,linearize,
              -- * Trees
@@ -102,7 +103,28 @@ abstractName p = unsafePerformIO (peekCString =<< pgf_abstract_name (pgf p))
 
 startCat :: PGF -> String
 startCat p = unsafePerformIO (peekCString =<< pgf_start_cat (pgf p))
- 
+
+loadConcr :: Concr -> FilePath -> IO ()
+loadConcr c fpath =
+  withCString fpath $ \c_fpath ->
+  withCString "rb" $ \c_mode ->
+  withGuPool $ \tmpPl -> do
+    file <- fopen c_fpath c_mode
+    inp <- gu_file_in file tmpPl
+    exn <- gu_new_exn nullPtr gu_type__type tmpPl
+    pgf_concrete_load (concr c) inp exn
+    failed <- gu_exn_is_raised exn
+    if failed
+      then do ty <- gu_exn_caught exn
+              if ty == gu_type__GuErrno
+                then do perrno <- (#peek GuExn, data.data) exn
+                        errno  <- peek perrno
+                        ioError (errnoToIOError "loadConcr" (Errno errno) Nothing (Just fpath))
+                else do throwIO (PGFError "The language cannot be loaded")
+      else return ()
+
+unloadConcr :: Concr -> IO ()
+unloadConcr c = pgf_concrete_unload (concr c)
 
 -----------------------------------------------------------------------------
 -- Expressions
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 35ed15958..b686a8ee9 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -2,7 +2,7 @@
 
 module PGF2.FFI where
 
---import Foreign.C
+import Foreign.C
 import Foreign.C.String
 import Foreign.Ptr
 import Foreign.ForeignPtr
@@ -22,9 +22,14 @@ data GuMapItor
 data GuOut
 data GuPool
 
+foreign import ccall fopen :: CString -> CString -> IO (Ptr ())
+
 foreign import ccall "gu/mem.h gu_new_pool"
   gu_new_pool :: IO (Ptr GuPool)
 
+foreign import ccall "gu/mem.h gu_malloc"
+  gu_malloc :: Ptr GuPool -> CInt -> IO (Ptr a)
+
 foreign import ccall "gu/mem.h gu_pool_free"
   gu_pool_free :: Ptr GuPool -> IO ()
 
@@ -64,6 +69,9 @@ foreign import ccall "gu/string.h gu_string_buf"
 foreign import ccall "gu/string.h gu_string_buf_out"
   gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut)
 
+foreign import ccall "gu/file.h gu_file_in"
+  gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn)
+
 foreign import ccall "gu/enum.h gu_enum_next"
   gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
 
@@ -102,6 +110,12 @@ foreign import ccall "pgf/pgf.h pgf_get_language"
 foreign import ccall "pgf/pgf.h pgf_concrete_name"
   pgf_concrete_name :: Ptr PgfConcr -> IO CString
 
+foreign import ccall "pgf/pgf.h pgf_concrete_load"
+  pgf_concrete_load :: Ptr PgfConcr -> Ptr GuIn -> Ptr GuExn -> IO ()
+
+foreign import ccall "pgf/pgf.h pgf_concrete_unload"
+  pgf_concrete_unload :: Ptr PgfConcr -> IO ()
+
 foreign import ccall "pgf/pgf.h pgf_language_code"
   pgf_language_code :: Ptr PgfConcr -> IO CString
 
@@ -155,10 +169,10 @@ 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 Int
+  pgf_expr_arity :: PgfExpr -> IO CInt
 
 foreign import ccall "pgf/expr.h pgf_print_expr"
-  pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> Int -> Ptr GuOut -> Ptr GuExn -> IO ()
+  pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
 
 foreign import ccall "pgf/pgf.h pgf_generate_all"
   pgf_generate_all :: Ptr PgfPGF -> CString -> Ptr GuPool -> IO (Ptr GuEnum)