mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-09-28 13:13:37 -06:00
build the parse table when compiling from sources
This commit is contained in:
Krasimir Angelov
@@ -595,7 +595,12 @@ checkContext :: PGF -> [Hypo] -> Either String [Hypo]
|
||||
checkContext pgf ctxt = Right ctxt
|
||||
|
||||
compute :: PGF -> Expr -> Expr
|
||||
compute = error "TODO: compute"
|
||||
compute p e =
|
||||
unsafePerformIO $
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
bracket (newStablePtr e) freeStablePtr $ \c_e ->
|
||||
bracket (withPgfExn "compute" (pgf_compute (a_db p) c_revision c_e marshaller unmarshaller)) freeStablePtr $ \c_e ->
|
||||
deRefStablePtr c_e
|
||||
|
||||
concreteName :: Concr -> ConcName
|
||||
concreteName c =
|
||||
|
||||
@@ -50,6 +50,7 @@ data PgfMorphoCallback
|
||||
data PgfCohortsCallback
|
||||
data PgfExprEnum
|
||||
data PgfAlignmentPhrase
|
||||
data PgfParseTableMaker
|
||||
|
||||
type Wrapper a = a -> IO (FunPtr a)
|
||||
type Dynamic a = FunPtr a -> a
|
||||
@@ -205,6 +206,8 @@ foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Ex
|
||||
|
||||
foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
|
||||
|
||||
foreign import ccall pgf_compute :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
|
||||
|
||||
foreign import ccall pgf_generate_random :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Type -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
|
||||
|
||||
foreign import ccall pgf_generate_random_from :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
|
||||
@@ -225,9 +228,11 @@ foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText
|
||||
|
||||
foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr)
|
||||
foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr)
|
||||
|
||||
foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr)
|
||||
foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr)
|
||||
|
||||
foreign import ccall pgf_free_parse_table :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> IO ()
|
||||
|
||||
foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
@@ -249,13 +254,13 @@ foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIfac
|
||||
|
||||
foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO CSize)
|
||||
|
||||
foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
|
||||
module PGF2.Transactions
|
||||
( -- transactions
|
||||
TxnID
|
||||
@@ -50,27 +50,31 @@ import Data.IORef
|
||||
#include <pgf/pgf.h>
|
||||
|
||||
newtype Transaction k a =
|
||||
Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a)
|
||||
Transaction (Ptr PgfDB -> Ptr PGF -> TransactionCtxt k -> Ptr PgfExn -> IO a)
|
||||
|
||||
type family TransactionCtxt a
|
||||
type instance TransactionCtxt PGF = ()
|
||||
type instance TransactionCtxt Concr = (Ptr Concr, Ptr PgfParseTableMaker)
|
||||
|
||||
instance Functor (Transaction k) where
|
||||
fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do
|
||||
res <- g c_db c_abstr c_revision c_exn
|
||||
fmap f (Transaction g) = Transaction $ \c_db c_abstr ctxt c_exn -> do
|
||||
res <- g c_db c_abstr ctxt c_exn
|
||||
return (f res)
|
||||
|
||||
instance Applicative (Transaction k) where
|
||||
pure x = Transaction $ \c_db _ c_revision c_exn -> return x
|
||||
pure x = Transaction $ \c_db _ _ c_exn -> return x
|
||||
f <*> g = do
|
||||
f <- f
|
||||
g <- g
|
||||
return (f g)
|
||||
|
||||
instance Monad (Transaction k) where
|
||||
(Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do
|
||||
res <- f c_db c_abstr c_revision c_exn
|
||||
(Transaction f) >>= g = Transaction $ \c_db c_abstr ctxt c_exn -> do
|
||||
res <- f c_db c_abstr ctxt c_exn
|
||||
ex_type <- (#peek PgfExn, type) c_exn
|
||||
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
|
||||
then case g res of
|
||||
Transaction g -> g c_db c_abstr c_revision c_exn
|
||||
Transaction g -> g c_db c_abstr ctxt c_exn
|
||||
else return undefined
|
||||
|
||||
#if !(MIN_VERSION_base(4,13,0))
|
||||
@@ -79,7 +83,7 @@ instance Monad (Transaction k) where
|
||||
#endif
|
||||
|
||||
instance Fail.MonadFail (Transaction k) where
|
||||
fail msg = Transaction $ \c_db c_abstr c_revision c_exn -> fail msg
|
||||
fail msg = Transaction $ \c_db c_abstr ctxt c_exn -> fail msg
|
||||
|
||||
data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF)
|
||||
|
||||
@@ -103,7 +107,7 @@ inTransaction :: TxnID -> Transaction PGF a -> IO a
|
||||
inTransaction (TxnID db fptr) (Transaction f) =
|
||||
withForeignPtr fptr $ \c_revision -> do
|
||||
withPgfExn "inTransaction" $ \c_exn ->
|
||||
f db c_revision c_revision c_exn
|
||||
f db c_revision () c_exn
|
||||
|
||||
{- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
|
||||
transaction @t@. The changes are applied to the new grammar
|
||||
@@ -117,7 +121,7 @@ modifyPGF p (Transaction f) =
|
||||
c_revision <- pgf_start_transaction (a_db p) c_exn
|
||||
ex_type <- (#peek PgfExn, type) c_exn
|
||||
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
|
||||
then do ((restore (f (a_db p) c_revision c_revision c_exn))
|
||||
then do ((restore (f (a_db p) c_revision () c_exn))
|
||||
`catch`
|
||||
(\e -> do
|
||||
pgf_free_revision_ (a_db p) c_revision
|
||||
@@ -151,11 +155,11 @@ checkoutPGF p = do
|
||||
already a function with the same name then an exception is thrown.
|
||||
-}
|
||||
createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fun
|
||||
createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
|
||||
createFunction name ty arity bytecode prob = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
|
||||
(if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do
|
||||
c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
|
||||
c_name <- pgf_create_function c_db c_abstr c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
|
||||
if c_name == nullPtr
|
||||
then return ""
|
||||
else do name <- peekText c_name
|
||||
@@ -163,68 +167,72 @@ createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_
|
||||
return name
|
||||
|
||||
dropFunction :: Fun -> Transaction PGF ()
|
||||
dropFunction name = Transaction $ \c_db _ c_revision c_exn ->
|
||||
dropFunction name = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_drop_function c_db c_revision c_name c_exn
|
||||
pgf_drop_function c_db c_abstr c_name c_exn
|
||||
|
||||
createCategory :: Cat -> [Hypo] -> Float -> Transaction PGF ()
|
||||
createCategory name hypos prob = Transaction $ \c_db _ c_revision c_exn ->
|
||||
createCategory name hypos prob = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name ->
|
||||
withHypos hypos $ \n_hypos c_hypos -> do
|
||||
pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller c_exn
|
||||
pgf_create_category c_db c_abstr c_name n_hypos c_hypos prob marshaller c_exn
|
||||
|
||||
dropCategory :: Cat -> Transaction PGF ()
|
||||
dropCategory name = Transaction $ \c_db _ c_revision c_exn ->
|
||||
dropCategory name = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_drop_category c_db c_revision c_name c_exn
|
||||
pgf_drop_category c_db c_abstr c_name c_exn
|
||||
|
||||
createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
|
||||
createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
bracketPtr (pgf_create_concrete c_db c_revision c_name c_exn)
|
||||
(pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
|
||||
f c_db c_abstr c_concr_revision c_exn
|
||||
createConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracketCnc c_exn
|
||||
(pgf_create_concrete c_db c_abstr c_name)
|
||||
(\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do
|
||||
f c_db c_abstr ctxt c_exn
|
||||
|
||||
alterConcrete :: ConcName -> Transaction Concr a -> Transaction PGF a
|
||||
alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
bracketPtr (pgf_clone_concrete c_db c_revision c_name c_exn)
|
||||
(pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
|
||||
f c_db c_abstr c_concr_revision c_exn
|
||||
bracketCnc c_exn
|
||||
(pgf_clone_concrete c_db c_abstr c_name)
|
||||
(\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do
|
||||
f c_db c_abstr ctxt c_exn
|
||||
|
||||
bracketPtr before after thing =
|
||||
bracketCnc c_exn before after thing =
|
||||
alloca $ \p_tm ->
|
||||
mask $ \restore -> do
|
||||
a <- before
|
||||
if a == nullPtr
|
||||
c <- before p_tm c_exn
|
||||
if c == nullPtr
|
||||
then return undefined
|
||||
else do r <- restore (thing a) `onException` after a
|
||||
_ <- after a
|
||||
else do tm <- peek p_tm
|
||||
r <- restore (thing (c,tm)) `onException` after c tm
|
||||
_ <- after c tm
|
||||
return r
|
||||
|
||||
dropConcrete :: ConcName -> Transaction PGF ()
|
||||
dropConcrete name = Transaction $ \c_db _ c_revision c_exn ->
|
||||
dropConcrete name = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_drop_concrete c_db c_revision c_name c_exn
|
||||
pgf_drop_concrete c_db c_abstr c_name c_exn
|
||||
|
||||
mergePGF :: FilePath -> Transaction PGF ()
|
||||
mergePGF fpath = Transaction $ \c_db _ c_revision c_exn ->
|
||||
mergePGF fpath = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withCString fpath $ \c_fpath ->
|
||||
pgf_merge_pgf c_db c_revision c_fpath c_exn
|
||||
pgf_merge_pgf c_db c_abstr c_fpath c_exn
|
||||
|
||||
setGlobalFlag :: String -> Literal -> Transaction PGF ()
|
||||
setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn ->
|
||||
setGlobalFlag name value = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr value) freeStablePtr $ \c_value ->
|
||||
pgf_set_global_flag c_db c_revision c_name c_value marshaller c_exn
|
||||
pgf_set_global_flag c_db c_abstr c_name c_value marshaller c_exn
|
||||
|
||||
setAbstractFlag :: String -> Literal -> Transaction PGF ()
|
||||
setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn ->
|
||||
setAbstractFlag name value = Transaction $ \c_db c_abstr _ c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr value) freeStablePtr $ \c_value ->
|
||||
pgf_set_abstract_flag c_db c_revision c_name c_value marshaller c_exn
|
||||
pgf_set_abstract_flag c_db c_abstr c_name c_value marshaller c_exn
|
||||
|
||||
setConcreteFlag :: String -> Literal -> Transaction Concr ()
|
||||
setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn ->
|
||||
setConcreteFlag name value = Transaction $ \c_db _ (c_revision,_) c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr value) freeStablePtr $ \c_value ->
|
||||
pgf_set_concrete_flag c_db c_revision c_name c_value marshaller c_exn
|
||||
@@ -258,13 +266,13 @@ data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
|
||||
deriving (Eq,Show)
|
||||
|
||||
createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr ()
|
||||
createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
|
||||
let n_fields = length fields
|
||||
in withText name $ \c_name ->
|
||||
allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
|
||||
withTexts c_fields 0 fields $
|
||||
withBuildLinIface (lindefs++linrefs) $ \c_build ->
|
||||
pgf_create_lincat c_db c_abstr c_revision c_name
|
||||
pgf_create_lincat c_db c_abstr c_revision tm c_name
|
||||
(fromIntegral n_fields) c_fields
|
||||
(fromIntegral (length lindefs)) (fromIntegral (length linrefs))
|
||||
c_build c_exn
|
||||
@@ -276,21 +284,21 @@ createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revisio
|
||||
withTexts p (i+1) ss f
|
||||
|
||||
dropLincat :: Cat -> Transaction Concr ()
|
||||
dropLincat name = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
dropLincat name = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
|
||||
withText name $ \c_name ->
|
||||
pgf_drop_lincat c_db c_abstr c_revision c_name c_exn
|
||||
|
||||
createLin :: Fun -> [Rule] -> Transaction Concr ()
|
||||
createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
createLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
|
||||
withText name $ \c_name ->
|
||||
withBuildLinIface rules $ \c_build ->
|
||||
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
|
||||
pgf_create_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
|
||||
|
||||
alterLin :: Fun -> [Rule] -> Transaction Concr ()
|
||||
alterLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
alterLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
|
||||
withText name $ \c_name ->
|
||||
withBuildLinIface rules $ \c_build ->
|
||||
pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
|
||||
pgf_alter_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
|
||||
|
||||
withBuildLinIface rules f = do
|
||||
(allocaBytes (#size PgfBuildLinIface) $ \c_build ->
|
||||
@@ -394,12 +402,12 @@ withBuildLinIface rules f = do
|
||||
pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
|
||||
|
||||
dropLin :: Fun -> Transaction Concr ()
|
||||
dropLin name = Transaction $ \c_db c_abstr c_revision c_exn ->
|
||||
dropLin name = Transaction $ \c_db c_abstr (c_revision,_) c_exn ->
|
||||
withText name $ \c_name ->
|
||||
pgf_drop_lin c_db c_abstr c_revision c_name c_exn
|
||||
|
||||
setPrintName :: Fun -> String -> Transaction Concr ()
|
||||
setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->
|
||||
setPrintName fun name = Transaction $ \c_db _ (c_revision,_) c_exn ->
|
||||
withText fun $ \c_fun ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_set_printname c_db c_revision c_fun c_name c_exn
|
||||
@@ -422,7 +430,7 @@ getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do
|
||||
-- | A monadic version of 'categoryFields' which returns the fields of
|
||||
-- a category from grammar in the current transaction.
|
||||
getCategoryFields :: Cat -> Transaction Concr (Maybe [String])
|
||||
getCategoryFields cat = Transaction $ \c_db _ c_revision c_exn ->
|
||||
getCategoryFields cat = Transaction $ \c_db _ (c_revision,_) c_exn ->
|
||||
withText cat $ \c_cat ->
|
||||
alloca $ \p_n_fields -> do
|
||||
c_fields <- pgf_category_fields c_db c_revision c_cat p_n_fields c_exn
|
||||
|
||||
Reference in New Issue
Block a user