msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

change the API to allow different grammar revisions

Browse Source
This commit is contained in:
krangelov
2021-09-06 15:49:39 +02:00
parent b7cddf206b
commit 9cea2cc70e
14 changed files with 298 additions and 226 deletions
Download Patch File Download Diff File Expand all files Collapse all files

83
src/runtime/haskell/PGF2.hsc
View File

@@ -56,6 +56,7 @@ import PGF2.FFI
import Foreign
import Foreign.C
import qualified Foreign.Concurrent as C
import qualified Data.Map as Map
import Data.IORef
@@ -68,10 +69,13 @@ type ConcName = String -- ^ Name of concrete syntax
readPGF :: FilePath -> IO PGF
readPGF fpath =
withCString fpath $ \c_fpath ->
alloca $ \p_revision ->
mask_ $ do
c_pgf <- withPgfExn fpath (pgf_read_pgf c_fpath)
fptr <- newForeignPtr pgf_free_fptr c_pgf
return (PGF fptr Map.empty)
c_pgf <- withPgfExn fpath (pgf_read_pgf c_fpath p_revision)
c_revision <- peek p_revision
fptr1 <- newForeignPtr pgf_free_fptr c_pgf
fptr2 <- C.newForeignPtr c_revision (withForeignPtr fptr1 (\c_db -> pgf_free_revision c_db c_revision))
return (PGF fptr1 fptr2 Map.empty)
-- | Reads a PGF file and stores the unpacked data in an NGF file
-- ready to be shared with other process, or used for quick startup.
@@ -81,10 +85,13 @@ bootNGF :: FilePath -> FilePath -> IO PGF
bootNGF pgf_path ngf_path =
withCString pgf_path $ \c_pgf_path ->
withCString ngf_path $ \c_ngf_path ->
alloca $ \p_revision ->
mask_ $ do
c_pgf <- withPgfExn pgf_path (pgf_boot_ngf c_pgf_path c_ngf_path)
fptr <- newForeignPtr pgf_free_fptr c_pgf
return (PGF fptr Map.empty)
c_pgf <- withPgfExn pgf_path (pgf_boot_ngf c_pgf_path c_ngf_path p_revision)
c_revision <- peek p_revision
fptr1 <- newForeignPtr pgf_free_fptr c_pgf
fptr2 <- C.newForeignPtr c_revision (withForeignPtr fptr1 (\c_db -> pgf_free_revision c_db c_revision))
return (PGF fptr1 fptr2 Map.empty)
-- | Tries to read the grammar from an already booted NGF file.
-- If the file does not exist then a new one is created, and the
@@ -93,18 +100,22 @@ bootNGF pgf_path ngf_path =
readNGF :: FilePath -> IO PGF
readNGF fpath =
withCString fpath $ \c_fpath ->
alloca $ \p_revision ->
mask_ $ do
c_pgf <- withPgfExn fpath (pgf_read_ngf c_fpath)
fptr <- newForeignPtr pgf_free_fptr c_pgf
return (PGF fptr Map.empty)
c_db <- withPgfExn fpath (pgf_read_ngf c_fpath p_revision)
c_revision <- peek p_revision
fptr1 <- newForeignPtr pgf_free_fptr c_db
fptr2 <- C.newForeignPtr c_revision (withForeignPtr fptr1 (\c_db -> pgf_free_revision c_db c_revision))
return (PGF fptr1 fptr2 Map.empty)
-- | The abstract language name is the name of the top-level
-- abstract module
abstractName :: PGF -> AbsName
abstractName p =
unsafePerformIO $
withForeignPtr (a_pgf p) $ \p_pgf ->
bracket (pgf_abstract_name p_pgf) free $ \c_text ->
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
bracket (pgf_abstract_name c_db c_revision) free $ \c_text ->
peekText c_text
-- | The start category is defined in the grammar with
@@ -116,8 +127,9 @@ startCat :: PGF -> Type
startCat p =
unsafePerformIO $
withForeignPtr unmarshaller $ \u ->
withForeignPtr (a_pgf p) $ \c_pgf -> do
c_typ <- pgf_start_cat c_pgf u
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision -> do
c_typ <- pgf_start_cat c_db c_revision u
typ <- deRefStablePtr c_typ
freeStablePtr c_typ
return typ
@@ -127,9 +139,10 @@ functionType :: PGF -> Fun -> Maybe Type
functionType p fn =
unsafePerformIO $
withForeignPtr unmarshaller $ \u ->
withForeignPtr (a_pgf p) $ \p_pgf ->
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
withText fn $ \c_fn -> do
c_typ <- pgf_function_type p_pgf c_fn u
c_typ <- pgf_function_type c_db c_revision c_fn u
if c_typ == castPtrToStablePtr nullPtr
then return Nothing
else do typ <- deRefStablePtr c_typ
@@ -140,16 +153,18 @@ functionIsConstructor :: PGF -> Fun -> Bool
functionIsConstructor p fun =
unsafePerformIO $
withText fun $ \c_fun ->
withForeignPtr (a_pgf p) $ \c_pgf ->
do res <- pgf_function_is_constructor c_pgf c_fun
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
do res <- pgf_function_is_constructor c_db c_revision c_fun
return (res /= 0)
functionProb :: PGF -> Fun -> Float
functionProb p fun =
unsafePerformIO $
withText fun $ \c_fun ->
withForeignPtr (a_pgf p) $ \c_pgf ->
do c_prob <- pgf_function_prob c_pgf c_fun
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
do c_prob <- pgf_function_prob c_db c_revision c_fun
return (realToFrac c_prob)
-- | List of all functions defined in the abstract syntax
@@ -159,9 +174,10 @@ categories p =
ref <- newIORef []
(allocaBytes (#size PgfItor) $ \itor ->
bracket (wrapItorCallback (getCategories ref)) freeHaskellFunPtr $ \fptr ->
withForeignPtr (a_pgf p) $ \p_pgf -> do
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision -> do
(#poke PgfItor, fn) itor fptr
withPgfExn "" (pgf_iter_categories p_pgf itor)
withPgfExn "" (pgf_iter_categories c_db c_revision itor)
cs <- readIORef ref
return (reverse cs))
where
@@ -177,9 +193,10 @@ categoryContext p cat =
withText cat $ \c_cat ->
alloca $ \p_n_hypos ->
withForeignPtr unmarshaller $ \u ->
withForeignPtr (a_pgf p) $ \c_pgf ->
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
mask_ $ do
c_hypos <- pgf_category_context c_pgf c_cat p_n_hypos u
c_hypos <- pgf_category_context c_db c_revision c_cat p_n_hypos u
if c_hypos == nullPtr
then return []
else do n_hypos <- peek p_n_hypos
@@ -204,8 +221,9 @@ categoryProb :: PGF -> Cat -> Float
categoryProb p cat =
unsafePerformIO $
withText cat $ \c_cat ->
withForeignPtr (a_pgf p) $ \c_pgf ->
do c_prob <- pgf_category_prob c_pgf c_cat
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
do c_prob <- pgf_category_prob c_db c_revision c_cat
return (realToFrac c_prob)
-- | List of all functions defined in the abstract syntax
@@ -215,9 +233,10 @@ functions p =
ref <- newIORef []
(allocaBytes (#size PgfItor) $ \itor ->
bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
withForeignPtr (a_pgf p) $ \p_pgf -> do
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision -> do
(#poke PgfItor, fn) itor fptr
withPgfExn "" (pgf_iter_functions p_pgf itor)
withPgfExn "" (pgf_iter_functions c_db c_revision itor)
fs <- readIORef ref
return (reverse fs))
where
@@ -235,9 +254,10 @@ functionsByCat p cat =
(withText cat $ \c_cat ->
allocaBytes (#size PgfItor) $ \itor ->
bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
withForeignPtr (a_pgf p) $ \p_pgf -> do
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision -> do
(#poke PgfItor, fn) itor fptr
withPgfExn "" (pgf_iter_functions_by_cat p_pgf c_cat itor)
withPgfExn "" (pgf_iter_functions_by_cat c_db c_revision c_cat itor)
fs <- readIORef ref
return (reverse fs))
where
@@ -319,8 +339,9 @@ readType str =
createFunction :: PGF -> Fun -> Type -> Float -> IO ()
createFunction p name ty prob =
withForeignPtr (a_pgf p) $ \p_pgf ->
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
withText name $ \c_name ->
bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
withForeignPtr marshaller $ \m -> do
pgf_create_function p_pgf c_name c_ty prob m
pgf_create_function c_db c_revision c_name c_ty prob m

43
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -20,8 +20,11 @@ import PGF2.Expr
-- | An abstract data type representing multilingual grammar
-- in Portable Grammar Format.
data PGF = PGF {a_pgf :: ForeignPtr PgfPGF, langs :: Map.Map String Concr}
data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
data PGF = PGF { a_db :: ForeignPtr PgfDB
, revision :: ForeignPtr PgfRevision
, langs :: Map.Map String Concr
}
data Concr = Concr {c_pgf :: ForeignPtr PgfDB, concr :: Ptr PgfConcr}
------------------------------------------------------------------
-- libpgf API
@@ -29,7 +32,8 @@ data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
data PgfExn
data PgfText
data PgfItor
data PgfPGF
data PgfDB
data PgfRevision
data PgfPrintContext
data PgfConcr
data PgfTypeHypo
@@ -43,19 +47,22 @@ foreign import ccall unsafe "pgf_utf8_encode"
pgf_utf8_encode :: Word32 -> Ptr CString -> IO ()
foreign import ccall "pgf_read_pgf"
pgf_read_pgf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
pgf_read_pgf :: CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
foreign import ccall "pgf_boot_ngf"
pgf_boot_ngf :: CString -> CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
pgf_boot_ngf :: CString -> CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
foreign import ccall "pgf_read_ngf"
pgf_read_ngf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
pgf_read_ngf :: CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
foreign import ccall "&pgf_free"
pgf_free_fptr :: FinalizerPtr PgfPGF
pgf_free_fptr :: FinalizerPtr PgfDB
foreign import ccall "pgf_free_revision"
pgf_free_revision :: Ptr PgfDB -> Ptr PgfRevision -> IO ()
foreign import ccall "pgf_abstract_name"
pgf_abstract_name :: Ptr PgfPGF -> IO (Ptr PgfText)
pgf_abstract_name :: Ptr PgfDB -> Ptr PgfRevision -> IO (Ptr PgfText)
foreign import ccall "pgf_print_expr"
pgf_print_expr :: StablePtr Expr -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
@@ -75,34 +82,34 @@ foreign import ccall "wrapper"
wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback)
foreign import ccall "pgf_iter_categories"
pgf_iter_categories :: Ptr PgfPGF -> Ptr PgfItor -> Ptr PgfExn -> IO ()
pgf_iter_categories :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfItor -> Ptr PgfExn -> IO ()
foreign import ccall "pgf_start_cat"
pgf_start_cat :: Ptr PgfPGF -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
pgf_start_cat :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
foreign import ccall "pgf/pgf.h pgf_category_context"
pgf_category_context :: Ptr PgfPGF -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> IO (Ptr PgfTypeHypo)
pgf_category_context :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> IO (Ptr PgfTypeHypo)
foreign import ccall "pgf/pgf.h pgf_category_prob"
pgf_category_prob :: Ptr PgfPGF -> Ptr PgfText -> IO (#type prob_t)
pgf_category_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> IO (#type prob_t)
foreign import ccall "pgf_iter_functions"
pgf_iter_functions :: Ptr PgfPGF -> Ptr PgfItor -> Ptr PgfExn -> IO ()
pgf_iter_functions :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfItor -> Ptr PgfExn -> IO ()
foreign import ccall "pgf_iter_functions_by_cat"
pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_function_type"
pgf_function_type :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
pgf_function_type :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
foreign import ccall "pgf/expr.h pgf_function_is_constructor"
pgf_function_is_constructor :: Ptr PgfPGF -> Ptr PgfText -> IO (#type int)
pgf_function_is_constructor :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> IO (#type int)
foreign import ccall "pgf/expr.h pgf_function_is_constructor"
pgf_function_prob :: Ptr PgfPGF -> Ptr PgfText -> IO (#type prob_t)
pgf_function_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> IO (#type prob_t)
foreign import ccall "pgf_create_function"
pgf_create_function :: Ptr PgfPGF -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> IO ()
pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> IO ()
-----------------------------------------------------------------------

3
src/runtime/haskell/tests/basic.hs
View File

@@ -74,8 +74,11 @@ main = do
print (e :: SomeException)
gr1 <- readPGF "tests/basic.pgf"
print (abstractName gr1)
gr2 <- bootNGF "tests/basic.pgf" "tests/basic.ngf"
print (abstractName gr2)
gr3 <- readNGF "tests/basic.ngf"
print (abstractName gr3)
rp1 <- testLoadFailure (readPGF "non-existing.pgf")
rp2 <- testLoadFailure (readPGF "tests/basic.gf")