forked from GitHub/gf-core
339 lines
12 KiB
Haskell
339 lines
12 KiB
Haskell
{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
|
|
|
|
module PGF2.FFI where
|
|
|
|
import Foreign ( alloca, poke )
|
|
import Foreign.C
|
|
import Foreign.Ptr
|
|
import Foreign.ForeignPtr
|
|
import Control.Exception
|
|
import GHC.Ptr
|
|
import Data.Int(Int32)
|
|
|
|
-- | An abstract data type representing multilingual grammar
|
|
-- in Portable Grammar Format.
|
|
data PGF = PGF {pgf :: Ptr PgfPGF, pgfMaster :: ForeignPtr GuPool}
|
|
data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF}
|
|
|
|
------------------------------------------------------------------
|
|
-- libgu API
|
|
|
|
data GuEnum
|
|
data GuExn
|
|
data GuIn
|
|
data GuKind
|
|
data GuType
|
|
data GuString
|
|
data GuStringBuf
|
|
data GuMapItor
|
|
data GuOut
|
|
data GuSeq
|
|
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 ()
|
|
|
|
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 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 -> CString -> IO Bool
|
|
|
|
gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString
|
|
|
|
gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString
|
|
|
|
gu_exn_type_PgfExn = Ptr "PgfExn"# :: CString
|
|
|
|
gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString
|
|
|
|
gu_exn_type_PgfTypeError = Ptr "PgfTypeError"# :: CString
|
|
|
|
foreign import ccall "gu/string.h gu_string_in"
|
|
gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn)
|
|
|
|
foreign import ccall "gu/string.h gu_string_buf"
|
|
gu_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf)
|
|
|
|
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 ()
|
|
|
|
foreign import ccall "gu/string.h gu_string_buf_freeze"
|
|
gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
|
|
|
|
foreign import ccall unsafe "gu/utf8.h gu_utf8_decode"
|
|
gu_utf8_decode :: Ptr CString -> IO Int32
|
|
|
|
foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
|
|
gu_utf8_encode :: Int32 -> Ptr CString -> IO ()
|
|
|
|
foreign import ccall unsafe "gu/seq.h gu_make_seq"
|
|
gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq)
|
|
|
|
withGuPool :: (Ptr GuPool -> IO a) -> IO a
|
|
withGuPool f = bracket gu_new_pool gu_pool_free f
|
|
|
|
newOut :: Ptr GuPool -> IO (Ptr GuStringBuf, Ptr GuOut)
|
|
newOut pool =
|
|
do sb <- gu_string_buf pool
|
|
out <- gu_string_buf_out sb
|
|
return (sb,out)
|
|
|
|
peekUtf8CString :: CString -> IO String
|
|
peekUtf8CString ptr =
|
|
alloca $ \pptr ->
|
|
poke pptr ptr >> decode pptr
|
|
where
|
|
decode pptr = do
|
|
x <- gu_utf8_decode pptr
|
|
if x == 0
|
|
then return []
|
|
else do cs <- decode pptr
|
|
return (((toEnum . fromEnum) x) : cs)
|
|
|
|
newUtf8CString :: String -> Ptr GuPool -> IO CString
|
|
newUtf8CString s pool = do
|
|
-- An UTF8 character takes up to 6 bytes. We allocate enough
|
|
-- memory for the worst case. This is wasteful but those
|
|
-- strings are usually allocated only temporary.
|
|
ptr <- gu_malloc pool (fromIntegral (length s * 6+1))
|
|
alloca $ \pptr ->
|
|
poke pptr ptr >> encode s pptr
|
|
return ptr
|
|
where
|
|
encode [] pptr = do
|
|
gu_utf8_encode 0 pptr
|
|
encode (c:cs) pptr = do
|
|
gu_utf8_encode ((toEnum . fromEnum) c) pptr
|
|
encode cs pptr
|
|
|
|
------------------------------------------------------------------
|
|
-- libpgf API
|
|
|
|
data PgfPGF
|
|
data PgfApplication
|
|
data PgfConcr
|
|
type PgfExpr = Ptr ()
|
|
data PgfExprProb
|
|
data PgfFullFormEntry
|
|
data PgfMorphoCallback
|
|
data PgfPrintContext
|
|
type PgfType = Ptr ()
|
|
data PgfCallbacksMap
|
|
data PgfOracleCallback
|
|
data PgfCncTree
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_read"
|
|
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_abstract_name"
|
|
pgf_abstract_name :: Ptr PgfPGF -> IO CString
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_iter_languages"
|
|
pgf_iter_languages :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_get_language"
|
|
pgf_get_language :: Ptr PgfPGF -> CString -> IO (Ptr PgfConcr)
|
|
|
|
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
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_iter_categories"
|
|
pgf_iter_categories :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_start_cat"
|
|
pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_iter_functions"
|
|
pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat"
|
|
pgf_iter_functions_by_cat :: Ptr PgfPGF -> CString -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_function_type"
|
|
pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_print_name"
|
|
pgf_print_name :: Ptr PgfConcr -> CString -> IO CString
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_has_linearization"
|
|
pgf_has_linearization :: Ptr PgfConcr -> CString -> IO Bool
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_linearize"
|
|
pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_lzr_concretize"
|
|
pgf_lzr_concretize :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref"
|
|
pgf_lzr_wrap_linref :: Ptr PgfCncTree -> Ptr GuPool -> IO (Ptr PgfCncTree)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple"
|
|
pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_align_words"
|
|
pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics"
|
|
pgf_parse_with_heuristics :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
|
|
|
|
type LiteralMatchCallback = CInt -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb)
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback)
|
|
|
|
type LiteralPredictCallback = CInt -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb)
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_new_callbacks_map"
|
|
pgf_new_callbacks_map :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
|
|
|
|
foreign import ccall
|
|
hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO ()
|
|
|
|
type OracleCallback = CString -> CString -> CInt -> IO Bool
|
|
type OracleLiteralCallback = CString -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb)
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapOracleCallback :: OracleCallback -> IO (FunPtr OracleCallback)
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapOracleLiteralCallback :: OracleLiteralCallback -> IO (FunPtr OracleLiteralCallback)
|
|
|
|
foreign import ccall
|
|
hspgf_new_oracle_callback :: CString -> FunPtr OracleCallback -> FunPtr OracleCallback -> FunPtr OracleLiteralCallback -> Ptr GuPool -> IO (Ptr PgfOracleCallback)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
|
|
pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
|
|
pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
|
|
|
|
type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapLookupMorphoCallback :: LookupMorphoCallback -> IO (FunPtr LookupMorphoCallback)
|
|
|
|
type MapItorCallback = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapMapItorCallback :: MapItorCallback -> IO (FunPtr MapItorCallback)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_fullform_lexicon"
|
|
pgf_fullform_lexicon :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr GuEnum)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_fullform_get_string"
|
|
pgf_fullform_get_string :: Ptr PgfFullFormEntry -> IO CString
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_fullform_get_analyses"
|
|
pgf_fullform_get_analyses :: Ptr PgfFullFormEntry -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_apply"
|
|
pgf_expr_apply :: Ptr PgfApplication -> Ptr GuPool -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_unapply"
|
|
pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_abs"
|
|
pgf_expr_abs :: CInt -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_unabs"
|
|
pgf_expr_unabs :: PgfExpr -> IO (Ptr a)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_meta"
|
|
pgf_expr_meta :: CInt -> Ptr GuPool -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_unmeta"
|
|
pgf_expr_unmeta :: PgfExpr -> IO (Ptr a)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_string"
|
|
pgf_expr_string :: CString -> Ptr GuPool -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_int"
|
|
pgf_expr_int :: CInt -> Ptr GuPool -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_float"
|
|
pgf_expr_float :: CDouble -> Ptr GuPool -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_expr_unlit"
|
|
pgf_expr_unlit :: PgfExpr -> CInt -> IO (Ptr a)
|
|
|
|
foreign import ccall "pgf/expr.h pgf_expr_arity"
|
|
pgf_expr_arity :: PgfExpr -> IO CInt
|
|
|
|
foreign import ccall "pgf/expr.h pgf_check_expr"
|
|
pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
|
|
|
|
foreign import ccall "pgf/expr.h pgf_infer_expr"
|
|
pgf_infer_expr :: Ptr PgfPGF -> Ptr PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO PgfType
|
|
|
|
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 ()
|
|
|
|
foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
|
|
pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/expr.h pgf_print_type"
|
|
pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_generate_all"
|
|
pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
|
|
|
|
foreign import ccall "pgf/pgf.h pgf_print"
|
|
pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/expr.h pgf_read_expr"
|
|
pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
|
|
|
|
foreign import ccall "pgf/expr.h pgf_read_expr_tuple"
|
|
pgf_read_expr_tuple :: Ptr GuIn -> CInt -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt
|
|
|
|
foreign import ccall "pgf/expr.h pgf_read_expr_matrix"
|
|
pgf_read_expr_matrix :: Ptr GuIn -> CInt -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
|
|
|
|
foreign import ccall "pgf/expr.h pgf_read_type"
|
|
pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType
|
|
|
|
foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
|
|
pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
|
|
|
|
foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
|
|
pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
|