From fb18482aeb8b95c639599430533b6d7adcda9176 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Wed, 10 Sep 2014 14:35:54 +0000 Subject: [PATCH] added loadConcr/unloadConcr to the Haskell binding. This exposes an API for loading grammars compiled with -split-pgf --- src/runtime/haskell-bind/PGF2.hsc | 24 +++++++++++++++++++++++- src/runtime/haskell-bind/PGF2/FFI.hs | 20 +++++++++++++++++--- 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)