mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-20 08:32:50 -06:00
API for adding concrete syntaxes. Garbage collection to be fixed!
This commit is contained in:
krangelov
@@ -67,7 +67,7 @@ module PGF2 (-- * PGF
|
||||
graphvizWordAlignment,
|
||||
|
||||
-- * Concrete syntax
|
||||
ConcName,Concr,languages,concreteName,languageCode,
|
||||
ConcName,Concr,languages,concreteName,languageCode,concreteFlag,
|
||||
|
||||
-- ** Linearization
|
||||
linearize, linearizeAll, tabularLinearize, tabularLinearizeAll,
|
||||
@@ -115,7 +115,8 @@ readPGF fpath =
|
||||
c_db <- withPgfExn "readPGF" (pgf_read_pgf c_fpath p_revision)
|
||||
c_revision <- peek p_revision
|
||||
fptr <- C.newForeignPtr c_revision (pgf_free_revision c_db c_revision)
|
||||
return (PGF c_db fptr Map.empty)
|
||||
langs <- getConcretes c_db fptr
|
||||
return (PGF c_db fptr langs)
|
||||
|
||||
-- | 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.
|
||||
@@ -130,7 +131,8 @@ bootNGF pgf_path ngf_path =
|
||||
c_db <- withPgfExn "bootNGF" (pgf_boot_ngf c_pgf_path c_ngf_path p_revision)
|
||||
c_revision <- peek p_revision
|
||||
fptr <- C.newForeignPtr c_revision (pgf_free_revision c_db c_revision)
|
||||
return (PGF c_db fptr Map.empty)
|
||||
langs <- getConcretes c_db fptr
|
||||
return (PGF c_db fptr langs)
|
||||
|
||||
-- | Reads the grammar from an already booted NGF file.
|
||||
-- The function fails if the file does not exist.
|
||||
@@ -142,7 +144,8 @@ readNGF fpath =
|
||||
c_db <- withPgfExn "readNGF" (pgf_read_ngf c_fpath p_revision)
|
||||
c_revision <- peek p_revision
|
||||
fptr <- C.newForeignPtr c_revision (pgf_free_revision c_db c_revision)
|
||||
return (PGF c_db fptr Map.empty)
|
||||
langs <- getConcretes c_db fptr
|
||||
return (PGF c_db fptr langs)
|
||||
|
||||
-- | Creates a new NGF file with a grammar with the given abstract_name.
|
||||
-- Aside from the name, the grammar is otherwise empty but can be later
|
||||
@@ -162,7 +165,7 @@ newNGF abs_name mb_fpath =
|
||||
writePGF :: FilePath -> PGF -> IO ()
|
||||
writePGF fpath p =
|
||||
withCString fpath $ \c_fpath ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withPgfExn "writePGF" (pgf_write_pgf c_fpath (a_db p) c_revision)
|
||||
|
||||
showPGF :: PGF -> String
|
||||
@@ -173,7 +176,7 @@ showPGF = error "TODO: showPGF"
|
||||
abstractName :: PGF -> AbsName
|
||||
abstractName p =
|
||||
unsafePerformIO $
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
bracket (withPgfExn "abstractName" (pgf_abstract_name (a_db p) c_revision)) free $ \c_text ->
|
||||
peekText c_text
|
||||
|
||||
@@ -186,7 +189,7 @@ startCat :: PGF -> Type
|
||||
startCat p =
|
||||
unsafePerformIO $
|
||||
withForeignPtr unmarshaller $ \u ->
|
||||
withForeignPtr (revision p) $ \c_revision -> do
|
||||
withForeignPtr (a_revision p) $ \c_revision -> do
|
||||
c_typ <- withPgfExn "startCat" (pgf_start_cat (a_db p) c_revision u)
|
||||
typ <- deRefStablePtr c_typ
|
||||
freeStablePtr c_typ
|
||||
@@ -197,7 +200,7 @@ functionType :: PGF -> Fun -> Maybe Type
|
||||
functionType p fn =
|
||||
unsafePerformIO $
|
||||
withForeignPtr unmarshaller $ \u ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withText fn $ \c_fn -> do
|
||||
c_typ <- withPgfExn "functionType" (pgf_function_type (a_db p) c_revision c_fn u)
|
||||
if c_typ == castPtrToStablePtr nullPtr
|
||||
@@ -210,7 +213,7 @@ functionIsConstructor :: PGF -> Fun -> Bool
|
||||
functionIsConstructor p fun =
|
||||
unsafePerformIO $
|
||||
withText fun $ \c_fun ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
do res <- withPgfExn "functionIsConstructor" (pgf_function_is_constructor (a_db p) c_revision c_fun)
|
||||
return (res /= 0)
|
||||
|
||||
@@ -218,13 +221,13 @@ functionProbability :: PGF -> Fun -> Float
|
||||
functionProbability p fun =
|
||||
unsafePerformIO $
|
||||
withText fun $ \c_fun ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withPgfExn "functionProbability" (pgf_function_prob (a_db p) c_revision c_fun)
|
||||
|
||||
exprProbability :: PGF -> Expr -> Float
|
||||
exprProbability p e =
|
||||
unsafePerformIO $
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
bracket (newStablePtr e) freeStablePtr $ \c_e ->
|
||||
withForeignPtr marshaller $ \m ->
|
||||
withPgfExn "exprProbability" (pgf_expr_prob (a_db p) c_revision c_e m)
|
||||
@@ -248,10 +251,33 @@ compute :: PGF -> Expr -> Expr
|
||||
compute = error "TODO: compute"
|
||||
|
||||
concreteName :: Concr -> ConcName
|
||||
concreteName c = error "TODO: concreteName"
|
||||
concreteName c =
|
||||
unsafePerformIO $
|
||||
withForeignPtr (c_revision c) $ \c_revision ->
|
||||
bracket (withPgfExn "concreteName" (pgf_concrete_name (c_db c) c_revision)) free $ \c_text ->
|
||||
peekText c_text
|
||||
|
||||
languageCode :: Concr -> Maybe String
|
||||
languageCode c = error "TODO: languageCode"
|
||||
languageCode c =
|
||||
unsafePerformIO $
|
||||
withForeignPtr (c_revision c) $ \c_revision ->
|
||||
bracket (withPgfExn "languageCode" (pgf_concrete_language_code (c_db c) c_revision)) free $ \c_text ->
|
||||
if c_text == nullPtr
|
||||
then return Nothing
|
||||
else fmap Just (peekText c_text)
|
||||
|
||||
concreteFlag :: Concr -> String -> Maybe Literal
|
||||
concreteFlag c name =
|
||||
unsafePerformIO $
|
||||
withText name $ \c_name ->
|
||||
withForeignPtr (c_revision c) $ \c_revision ->
|
||||
withForeignPtr unmarshaller $ \u -> do
|
||||
c_lit <- withPgfExn "concreteFlag" (pgf_get_concrete_flag (c_db c) c_revision c_name u)
|
||||
if c_lit == castPtrToStablePtr nullPtr
|
||||
then return Nothing
|
||||
else do lit <- deRefStablePtr c_lit
|
||||
freeStablePtr c_lit
|
||||
return (Just lit)
|
||||
|
||||
printName :: Concr -> Fun -> Maybe String
|
||||
printName lang fun = error "TODO: printName"
|
||||
@@ -492,14 +518,14 @@ categories p =
|
||||
ref <- newIORef []
|
||||
(allocaBytes (#size PgfItor) $ \itor ->
|
||||
bracket (wrapItorCallback (getCategories ref)) freeHaskellFunPtr $ \fptr ->
|
||||
withForeignPtr (revision p) $ \c_revision -> do
|
||||
withForeignPtr (a_revision p) $ \c_revision -> do
|
||||
(#poke PgfItor, fn) itor fptr
|
||||
withPgfExn "categories" (pgf_iter_categories (a_db p) c_revision itor)
|
||||
cs <- readIORef ref
|
||||
return (reverse cs))
|
||||
where
|
||||
getCategories :: IORef [String] -> ItorCallback
|
||||
getCategories ref itor key exn = do
|
||||
getCategories ref itor key _ exn = do
|
||||
names <- readIORef ref
|
||||
name <- peekText key
|
||||
writeIORef ref $ (name : names)
|
||||
@@ -510,7 +536,7 @@ categoryContext p cat =
|
||||
withText cat $ \c_cat ->
|
||||
alloca $ \p_n_hypos ->
|
||||
withForeignPtr unmarshaller $ \u ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
mask_ $ do
|
||||
c_hypos <- withPgfExn "categoryContext" (pgf_category_context (a_db p) c_revision c_cat p_n_hypos u)
|
||||
if c_hypos == nullPtr
|
||||
@@ -537,7 +563,7 @@ categoryProbability :: PGF -> Cat -> Float
|
||||
categoryProbability p cat =
|
||||
unsafePerformIO $
|
||||
withText cat $ \c_cat ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withPgfExn "categoryProbability" (pgf_category_prob (a_db p) c_revision c_cat)
|
||||
|
||||
-- | List of all functions defined in the abstract syntax
|
||||
@@ -547,14 +573,14 @@ functions p =
|
||||
ref <- newIORef []
|
||||
(allocaBytes (#size PgfItor) $ \itor ->
|
||||
bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
|
||||
withForeignPtr (revision p) $ \c_revision -> do
|
||||
withForeignPtr (a_revision p) $ \c_revision -> do
|
||||
(#poke PgfItor, fn) itor fptr
|
||||
withPgfExn "functions" (pgf_iter_functions (a_db p) c_revision itor)
|
||||
fs <- readIORef ref
|
||||
return (reverse fs))
|
||||
where
|
||||
getFunctions :: IORef [String] -> ItorCallback
|
||||
getFunctions ref itor key exn = do
|
||||
getFunctions ref itor key _ exn = do
|
||||
names <- readIORef ref
|
||||
name <- peekText key
|
||||
writeIORef ref $ (name : names)
|
||||
@@ -567,14 +593,14 @@ functionsByCat p cat =
|
||||
(withText cat $ \c_cat ->
|
||||
allocaBytes (#size PgfItor) $ \itor ->
|
||||
bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
|
||||
withForeignPtr (revision p) $ \c_revision -> do
|
||||
withForeignPtr (a_revision p) $ \c_revision -> do
|
||||
(#poke PgfItor, fn) itor fptr
|
||||
withPgfExn "functionsByCat" (pgf_iter_functions_by_cat (a_db p) c_revision c_cat itor)
|
||||
fs <- readIORef ref
|
||||
return (reverse fs))
|
||||
where
|
||||
getFunctions :: IORef [String] -> ItorCallback
|
||||
getFunctions ref itor key exn = do
|
||||
getFunctions ref itor key _ exn = do
|
||||
names <- readIORef ref
|
||||
name <- peekText key
|
||||
writeIORef ref $ (name : names)
|
||||
@@ -583,7 +609,7 @@ globalFlag :: PGF -> String -> Maybe Literal
|
||||
globalFlag p name =
|
||||
unsafePerformIO $
|
||||
withText name $ \c_name ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withForeignPtr unmarshaller $ \u -> do
|
||||
c_lit <- withPgfExn "globalFlag" (pgf_get_global_flag (a_db p) c_revision c_name u)
|
||||
if c_lit == castPtrToStablePtr nullPtr
|
||||
@@ -596,7 +622,7 @@ abstractFlag :: PGF -> String -> Maybe Literal
|
||||
abstractFlag p name =
|
||||
unsafePerformIO $
|
||||
withText name $ \c_name ->
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withForeignPtr unmarshaller $ \u -> do
|
||||
c_lit <- withPgfExn "abstractFlag" (pgf_get_abstract_flag (a_db p) c_revision c_name u)
|
||||
if c_lit == castPtrToStablePtr nullPtr
|
||||
|
||||
@@ -6,10 +6,12 @@ import GHC.Exts
|
||||
import GHC.Prim
|
||||
import GHC.Integer.Logarithms
|
||||
import Data.Word
|
||||
import Data.IORef
|
||||
import Data.Typeable
|
||||
import Foreign
|
||||
import Foreign.C
|
||||
import Foreign.Ptr
|
||||
import qualified Foreign.Concurrent as C
|
||||
import qualified Data.Map as Map
|
||||
import Control.Exception(Exception,bracket,mask_,throwIO)
|
||||
import System.IO.Unsafe(unsafePerformIO)
|
||||
@@ -23,11 +25,11 @@ type ConcName = String -- ^ Name of concrete syntax
|
||||
|
||||
-- | An abstract data type representing multilingual grammar
|
||||
-- in Portable Grammar Format.
|
||||
data PGF = PGF { a_db :: Ptr PgfDB
|
||||
, revision :: ForeignPtr PgfRevision
|
||||
, languages:: Map.Map ConcName Concr
|
||||
data PGF = PGF { a_db :: Ptr PgfDB
|
||||
, a_revision :: ForeignPtr (PgfRevision PGF)
|
||||
, languages :: Map.Map ConcName Concr
|
||||
}
|
||||
data Concr = Concr {c_pgf :: Ptr PgfDB, concr :: Ptr PgfConcr}
|
||||
data Concr = Concr {c_db :: Ptr PgfDB, c_revision :: ForeignPtr (PgfRevision Concr)}
|
||||
|
||||
------------------------------------------------------------------
|
||||
-- libpgf API
|
||||
@@ -36,9 +38,8 @@ data PgfExn
|
||||
data PgfText
|
||||
data PgfItor
|
||||
data PgfDB
|
||||
data PgfRevision
|
||||
data PgfRevision a
|
||||
data PgfPrintContext
|
||||
data PgfConcr
|
||||
data PgfTypeHypo
|
||||
data PgfMarshaller
|
||||
data PgfUnmarshaller
|
||||
@@ -50,23 +51,24 @@ 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 (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
pgf_read_pgf :: CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
|
||||
foreign import ccall "pgf_boot_ngf"
|
||||
pgf_boot_ngf :: CString -> CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
pgf_boot_ngf :: CString -> CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
|
||||
foreign import ccall "pgf_read_ngf"
|
||||
pgf_read_ngf :: CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
pgf_read_ngf :: CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
|
||||
foreign import ccall pgf_new_ngf :: Ptr PgfText -> CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
foreign import ccall pgf_new_ngf :: Ptr PgfText -> CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
|
||||
|
||||
foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf_free_revision"
|
||||
pgf_free_revision :: Ptr PgfDB -> Ptr PgfRevision -> IO ()
|
||||
foreign import ccall pgf_free_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> IO ()
|
||||
|
||||
foreign import ccall pgf_free_concr_revision :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> IO ()
|
||||
|
||||
foreign import ccall "pgf_abstract_name"
|
||||
pgf_abstract_name :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO (Ptr PgfText)
|
||||
pgf_abstract_name :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfExn -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall "pgf_print_expr"
|
||||
pgf_print_expr :: StablePtr Expr -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
|
||||
@@ -84,61 +86,77 @@ foreign import ccall pgf_print_context :: CSize -> Ptr PgfTypeHypo -> Ptr PgfPri
|
||||
foreign import ccall "pgf_read_type"
|
||||
pgf_read_type :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
|
||||
|
||||
type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback)
|
||||
|
||||
foreign import ccall "pgf_iter_categories"
|
||||
pgf_iter_categories :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
pgf_iter_categories :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_iter_concretes :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf_start_cat"
|
||||
pgf_start_cat :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
|
||||
pgf_start_cat :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_category_context"
|
||||
pgf_category_context :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo)
|
||||
pgf_category_context :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_category_prob"
|
||||
pgf_category_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
|
||||
pgf_category_prob :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
|
||||
|
||||
foreign import ccall "pgf_iter_functions"
|
||||
pgf_iter_functions :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
pgf_iter_functions :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf_iter_functions_by_cat"
|
||||
pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf_function_type"
|
||||
pgf_function_type :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
|
||||
pgf_function_type :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
|
||||
|
||||
foreign import ccall "pgf_function_is_constructor"
|
||||
pgf_function_is_constructor :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type int)
|
||||
pgf_function_is_constructor :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (#type int)
|
||||
|
||||
foreign import ccall "pgf_function_prob"
|
||||
pgf_function_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
|
||||
pgf_function_prob :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
|
||||
|
||||
foreign import ccall pgf_expr_prob :: Ptr PgfDB -> Ptr PgfRevision -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfExn -> IO (#type prob_t)
|
||||
foreign import ccall pgf_concrete_name :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfExn -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
|
||||
foreign import ccall pgf_concrete_language_code :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfExn -> IO (Ptr PgfText)
|
||||
|
||||
foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_expr_prob :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfExn -> IO (#type prob_t)
|
||||
|
||||
foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
|
||||
foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision PGF))
|
||||
|
||||
foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision PGF))
|
||||
|
||||
foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> CSize -> Ptr PgfTypeHypo -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
|
||||
foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> CSize -> Ptr PgfTypeHypo -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_get_abstract_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
|
||||
foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision Concr))
|
||||
|
||||
foreign import ccall pgf_set_abstract_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision Concr))
|
||||
|
||||
foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
|
||||
|
||||
foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_get_abstract_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
|
||||
|
||||
foreign import ccall pgf_set_abstract_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
|
||||
foreign import ccall pgf_get_concrete_flag :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
|
||||
|
||||
foreign import ccall pgf_set_concrete_flag :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
|
||||
|
||||
-----------------------------------------------------------------------
|
||||
-- Texts
|
||||
@@ -581,3 +599,19 @@ withHypos hypos f =
|
||||
(#peek PgfTypeHypo, type) ptr >>= freeStablePtr
|
||||
freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo))
|
||||
|
||||
getConcretes c_db c_revision = do
|
||||
ref <- newIORef Map.empty
|
||||
(withForeignPtr c_revision $ \c_revision ->
|
||||
allocaBytes (#size PgfItor) $ \itor ->
|
||||
bracket (wrapItorCallback (getConcretes ref)) freeHaskellFunPtr $ \fptr -> do
|
||||
(#poke PgfItor, fn) itor fptr
|
||||
withPgfExn "getConcretes" (pgf_iter_concretes c_db c_revision itor)
|
||||
readIORef ref)
|
||||
where
|
||||
getConcretes :: IORef (Map.Map ConcName Concr) -> ItorCallback
|
||||
getConcretes ref itor key c_revision exn = do
|
||||
print 1
|
||||
concrs <- readIORef ref
|
||||
name <- peekText key
|
||||
fptr <- C.newForeignPtr (castPtr c_revision) (pgf_free_concr_revision c_db (castPtr c_revision))
|
||||
writeIORef ref (Map.insert name (Concr c_db fptr) concrs)
|
||||
|
||||
@@ -9,8 +9,11 @@ module PGF2.Transactions
|
||||
, dropFunction
|
||||
, createCategory
|
||||
, dropCategory
|
||||
, createConcrete
|
||||
, dropConcrete
|
||||
, setGlobalFlag
|
||||
, setAbstractFlag
|
||||
, setConcreteFlag
|
||||
|
||||
-- concrete syntax
|
||||
, Token, LIndex, LParam, Symbol(..)
|
||||
@@ -26,22 +29,22 @@ import Control.Exception
|
||||
|
||||
#include <pgf/pgf.h>
|
||||
|
||||
newtype Transaction a =
|
||||
Transaction (Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO a)
|
||||
newtype Transaction k a =
|
||||
Transaction (Ptr PgfDB -> Ptr (PgfRevision k) -> Ptr PgfExn -> IO a)
|
||||
|
||||
instance Functor Transaction where
|
||||
instance Functor (Transaction k) where
|
||||
fmap f (Transaction g) = Transaction $ \c_db c_revision c_exn -> do
|
||||
res <- g c_db c_revision c_exn
|
||||
return (f res)
|
||||
|
||||
instance Applicative Transaction where
|
||||
instance Applicative (Transaction k) where
|
||||
pure x = Transaction $ \c_db c_revision c_exn -> return x
|
||||
f <*> g = do
|
||||
f <- f
|
||||
g <- g
|
||||
return (f g)
|
||||
|
||||
instance Monad Transaction where
|
||||
instance Monad (Transaction k) where
|
||||
(Transaction f) >>= g = Transaction $ \c_db c_revision c_exn -> do
|
||||
res <- f c_db c_revision c_exn
|
||||
ex_type <- (#peek PgfExn, type) c_exn
|
||||
@@ -65,20 +68,20 @@ instance Monad Transaction where
|
||||
both @gr1@ and @gr2@ will refer to the new grammar which contains
|
||||
the new function @foo@.
|
||||
-}
|
||||
modifyPGF :: PGF -> Transaction a -> IO PGF
|
||||
modifyPGF :: PGF -> Transaction PGF a -> IO PGF
|
||||
modifyPGF = branchPGF_ nullPtr
|
||||
|
||||
{- | @branchPGF gr branch_name t@ is similar to @modifyPGF gr t@,
|
||||
except that it stores the result as a branch with the given name.
|
||||
-}
|
||||
branchPGF :: PGF -> String -> Transaction a -> IO PGF
|
||||
branchPGF :: PGF -> String -> Transaction PGF a -> IO PGF
|
||||
branchPGF p name t =
|
||||
withText name $ \c_name ->
|
||||
branchPGF_ c_name p t
|
||||
|
||||
branchPGF_ :: Ptr PgfText -> PGF -> Transaction a -> IO PGF
|
||||
branchPGF_ :: Ptr PgfText -> PGF -> Transaction PGF a -> IO PGF
|
||||
branchPGF_ c_name p (Transaction f) =
|
||||
withForeignPtr (revision p) $ \c_revision ->
|
||||
withForeignPtr (a_revision p) $ \c_revision ->
|
||||
withPgfExn "branchPGF" $ \c_exn ->
|
||||
mask $ \restore -> do
|
||||
c_revision <- pgf_clone_revision (a_db p) c_revision c_name c_exn
|
||||
@@ -95,7 +98,8 @@ branchPGF_ c_name p (Transaction f) =
|
||||
ex_type <- (#peek PgfExn, type) c_exn
|
||||
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
|
||||
then do fptr <- C.newForeignPtr c_revision (pgf_free_revision (a_db p) c_revision)
|
||||
return (PGF (a_db p) fptr (languages p))
|
||||
langs <- getConcretes (a_db p) fptr
|
||||
return (PGF (a_db p) fptr langs)
|
||||
else do pgf_free_revision (a_db p) c_revision
|
||||
return p
|
||||
else do pgf_free_revision (a_db p) c_revision
|
||||
@@ -110,46 +114,70 @@ checkoutPGF p name =
|
||||
if c_revision == nullPtr
|
||||
then return Nothing
|
||||
else do fptr <- C.newForeignPtr c_revision (pgf_free_revision (a_db p) c_revision)
|
||||
return (Just (PGF (a_db p) fptr (languages p)))
|
||||
langs <- getConcretes (a_db p) fptr
|
||||
return (Just (PGF (a_db p) fptr langs))
|
||||
|
||||
createFunction :: Fun -> Type -> Int -> Float -> Transaction ()
|
||||
createFunction :: Fun -> Type -> Int -> Float -> Transaction PGF ()
|
||||
createFunction name ty arity prob = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
|
||||
withForeignPtr marshaller $ \m -> do
|
||||
pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) prob m c_exn
|
||||
|
||||
dropFunction :: Fun -> Transaction ()
|
||||
dropFunction :: Fun -> Transaction PGF ()
|
||||
dropFunction name = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_drop_function c_db c_revision c_name c_exn
|
||||
|
||||
createCategory :: Fun -> [Hypo] -> Float -> Transaction ()
|
||||
createCategory :: Fun -> [Hypo] -> Float -> Transaction PGF ()
|
||||
createCategory name hypos prob = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
withHypos hypos $ \n_hypos c_hypos ->
|
||||
withForeignPtr marshaller $ \m -> do
|
||||
pgf_create_category c_db c_revision c_name n_hypos c_hypos prob m c_exn
|
||||
|
||||
dropCategory :: Cat -> Transaction ()
|
||||
dropCategory :: Cat -> Transaction PGF ()
|
||||
dropCategory name = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_drop_category c_db c_revision c_name c_exn
|
||||
|
||||
setGlobalFlag :: String -> Literal -> Transaction ()
|
||||
createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
|
||||
createConcrete name (Transaction f) = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
c_concr_revision <- pgf_create_concrete c_db c_revision c_name c_exn
|
||||
f c_db c_concr_revision c_exn
|
||||
|
||||
alterConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
|
||||
alterConcrete name (Transaction f) = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
c_concr_revision <- pgf_clone_concrete c_db c_revision c_name c_exn
|
||||
f c_db c_concr_revision c_exn
|
||||
|
||||
dropConcrete :: ConcName -> Transaction PGF ()
|
||||
dropConcrete name = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name -> do
|
||||
pgf_drop_concrete c_db c_revision c_name c_exn
|
||||
|
||||
setGlobalFlag :: String -> Literal -> Transaction PGF ()
|
||||
setGlobalFlag name value = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr value) freeStablePtr $ \c_value ->
|
||||
withForeignPtr marshaller $ \m ->
|
||||
pgf_set_global_flag c_db c_revision c_name c_value m c_exn
|
||||
|
||||
setAbstractFlag :: String -> Literal -> Transaction ()
|
||||
setAbstractFlag :: String -> Literal -> Transaction PGF ()
|
||||
setAbstractFlag name value = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr value) freeStablePtr $ \c_value ->
|
||||
withForeignPtr marshaller $ \m ->
|
||||
pgf_set_abstract_flag c_db c_revision c_name c_value m c_exn
|
||||
|
||||
setConcreteFlag :: String -> Literal -> Transaction Concr ()
|
||||
setConcreteFlag name value = Transaction $ \c_db c_revision c_exn ->
|
||||
withText name $ \c_name ->
|
||||
bracket (newStablePtr value) freeStablePtr $ \c_value ->
|
||||
withForeignPtr marshaller $ \m ->
|
||||
pgf_set_concrete_flag c_db c_revision c_name c_value m c_exn
|
||||
|
||||
type Token = String
|
||||
type LIndex = Int
|
||||
|
||||
Reference in New Issue
Block a user