diff options
Diffstat (limited to 'src/runtime/haskell-bind')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 66 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hs | 24 |
2 files changed, 43 insertions, 47 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 32034bcfc..629e020ce 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -52,12 +52,12 @@ readPGF fpath = do pool <- gu_new_pool pgf <- withCString fpath $ \c_fpath -> withGuPool $ \tmpPl -> do - exn <- gu_new_exn nullPtr gu_type__type tmpPl + exn <- gu_new_exn tmpPl pgf <- pgf_read c_fpath pool exn failed <- gu_exn_is_raised exn if failed - then do ty <- gu_exn_caught exn - if ty == gu_type__GuErrno + then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno + if is_errno then do perrno <- (#peek GuExn, data.data) exn errno <- peek perrno gu_pool_free pool @@ -110,12 +110,12 @@ loadConcr c fpath = withGuPool $ \tmpPl -> do file <- fopen c_fpath c_mode inp <- gu_file_in file tmpPl - exn <- gu_new_exn nullPtr gu_type__type tmpPl + exn <- gu_new_exn 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 is_errno <- gu_exn_caught exn gu_exn_type_GuErrno + if is_errno then do perrno <- (#peek GuExn, data.data) exn errno <- peek perrno ioError (errnoToIOError "loadConcr" (Errno errno) Nothing (Just fpath)) @@ -158,7 +158,7 @@ readExpr str = withGuPool $ \tmpPl -> withCString str $ \c_str -> do guin <- gu_string_in c_str tmpPl - exn <- gu_new_exn nullPtr gu_type__type tmpPl + exn <- gu_new_exn tmpPl c_expr <- pgf_read_expr guin exprPl exn status <- gu_exn_is_raised exn if (not status && c_expr /= nullPtr) @@ -173,7 +173,7 @@ showExpr e = withGuPool $ \tmpPl -> do (sb,out) <- newOut tmpPl let printCtxt = nullPtr - exn <- gu_new_exn nullPtr gu_type__type tmpPl + exn <- gu_new_exn tmpPl pgf_print_expr (expr e) printCtxt 1 out exn s <- gu_string_buf_freeze sb tmpPl peekCString s @@ -235,28 +235,29 @@ parse lang cat sent = unsafePerformIO $ do parsePl <- gu_new_pool exprPl <- gu_new_pool - exn <- gu_new_exn nullPtr gu_type__type parsePl + exn <- gu_new_exn parsePl enum <- withCString cat $ \cat -> withCString sent $ \sent -> pgf_parse (concr lang) cat sent exn parsePl exprPl failed <- gu_exn_is_raised exn if failed - then do ty <- gu_exn_caught exn - if ty == gu_type__PgfParseError + then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError + if is_parse_error then do c_tok <- (#peek GuExn, data.data) exn tok <- peekCString c_tok gu_pool_free parsePl gu_pool_free exprPl return (Left tok) - else if ty == gu_type__PgfExn - then do c_msg <- (#peek GuExn, data.data) exn - msg <- peekCString c_msg - gu_pool_free parsePl - gu_pool_free exprPl - throwIO (PGFError msg) - else do gu_pool_free parsePl - gu_pool_free exprPl - throwIO (PGFError "Parsing failed") + else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn + if is_exn + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekCString c_msg + gu_pool_free parsePl + gu_pool_free exprPl + throwIO (PGFError msg) + else do gu_pool_free parsePl + gu_pool_free exprPl + throwIO (PGFError "Parsing failed") else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprs <- fromPgfExprEnum enum parseFPl (lang,exprFPl) @@ -271,12 +272,12 @@ addLiteral lang cat match = predict <- wrapLiteralPredictCallback predict_callback (#poke PgfLiteralCallback, match) callback match (#poke PgfLiteralCallback, predict) callback predict - exn <- gu_new_exn nullPtr gu_type__type tmp_pool + exn <- gu_new_exn tmp_pool pgf_concr_add_literal (concr lang) ccat callback exn failed <- gu_exn_is_raised exn if failed - then do ty <- gu_exn_caught exn - if ty == gu_type__PgfExn + then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn + if is_exn then do c_msg <- (#peek GuExn, data.data) exn msg <- peekCString c_msg throwIO (PGFError msg) @@ -295,7 +296,7 @@ addLiteral lang cat match = -- here we copy the expression to out_pool c_e <- withGuPool $ \tmpPl -> do - exn <- gu_new_exn nullPtr gu_type__type tmpPl + exn <- gu_new_exn tmpPl (sb,out) <- newOut tmpPl let printCtxt = nullPtr @@ -323,18 +324,19 @@ linearize :: Concr -> Expr -> String linearize lang e = unsafePerformIO $ withGuPool $ \pl -> do (sb,out) <- newOut pl - exn <- gu_new_exn nullPtr gu_type__type pl + exn <- gu_new_exn pl pgf_linearize (concr lang) (expr e) out exn failed <- gu_exn_is_raised exn if failed - then do ty <- gu_exn_caught exn - if ty == gu_type__PgfLinNonExist + then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist + if is_nonexist then return "" - else if ty == gu_type__PgfExn - then do c_msg <- (#peek GuExn, data.data) exn - msg <- peekCString c_msg - throwIO (PGFError msg) - else throwIO (PGFError "The abstract tree cannot be linearized") + else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn + if is_exn + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekCString c_msg + throwIO (PGFError msg) + else throwIO (PGFError "The abstract tree cannot be linearized") else do lin <- gu_string_buf_freeze sb pl peekCString lin diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index a467f7ddc..96c5b19fa 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} module PGF2.FFI where @@ -7,6 +7,7 @@ import Foreign.C.String import Foreign.Ptr import Foreign.ForeignPtr import Control.Exception +import GHC.Ptr ------------------------------------------------------------------ -- libgu API @@ -37,28 +38,21 @@ foreign import ccall "gu/mem.h &gu_pool_free" gu_pool_finalizer :: FinalizerPtr GuPool foreign import ccall "gu/exn.h gu_new_exn" - gu_new_exn :: Ptr GuExn -> Ptr GuKind -> Ptr GuPool -> IO (Ptr GuExn) + gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn) foreign import ccall "gu/exn.h gu_exn_is_raised" gu_exn_is_raised :: Ptr GuExn -> IO Bool -foreign import ccall "gu/exn.h gu_exn_caught" - gu_exn_caught :: Ptr GuExn -> IO (Ptr GuType) +foreign import ccall "gu/exn.h gu_exn_caught_" + gu_exn_caught :: Ptr GuExn -> CString -> IO Bool -foreign import ccall "gu/type.h &gu_type__type" - gu_type__type :: Ptr GuKind +gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString -foreign import ccall "gu/type.h &gu_type__GuErrno" - gu_type__GuErrno :: Ptr GuType +gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString -foreign import ccall "gu/type.h &gu_type__PgfLinNonExist" - gu_type__PgfLinNonExist :: Ptr GuType +gu_exn_type_PgfExn = Ptr "PgfExn"# :: CString -foreign import ccall "gu/type.h &gu_type__PgfExn" - gu_type__PgfExn :: Ptr GuType - -foreign import ccall "gu/type.h &gu_type__PgfParseError" - gu_type__PgfParseError :: Ptr GuType +gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString foreign import ccall "gu/string.h gu_string_in" gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) |