forked from GitHub/gf-core
320 lines
13 KiB
Haskell
320 lines
13 KiB
Haskell
module PGF2.Transactions
|
|
( Transaction
|
|
|
|
-- abstract syntax
|
|
, modifyPGF
|
|
, branchPGF
|
|
, checkoutPGF
|
|
, createFunction
|
|
, dropFunction
|
|
, createCategory
|
|
, dropCategory
|
|
, setGlobalFlag
|
|
, setAbstractFlag
|
|
|
|
-- concrete syntax
|
|
, Token, LIndex, LVar, LParam(..)
|
|
, PArg(..), Symbol(..), Production(..)
|
|
|
|
, createConcrete
|
|
, alterConcrete
|
|
, dropConcrete
|
|
, setConcreteFlag
|
|
, createLincat
|
|
, dropLincat
|
|
, createLin
|
|
, dropLin
|
|
) where
|
|
|
|
import PGF2.FFI
|
|
import PGF2.Expr
|
|
|
|
import Foreign
|
|
import Foreign.C
|
|
import Control.Exception
|
|
|
|
#include <pgf/pgf.h>
|
|
|
|
newtype Transaction k a =
|
|
Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a)
|
|
|
|
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
|
|
return (f res)
|
|
|
|
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 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
|
|
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
|
|
else return undefined
|
|
|
|
{- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
|
|
transaction @t@. The changes are applied to the new grammar
|
|
returned by the function, while any further operations with @gr@
|
|
will still work with the old grammar. The newly created grammar
|
|
also replaces the corresponding branch. In the example:
|
|
|
|
> do gr <- readPGF "my_grammar.pgf"
|
|
> Just ty = readType "S"
|
|
> gr1 <- modifyPGF gr (createFunction "foo" ty)
|
|
> gr2 <- checkoutPGF gr "master"
|
|
> print (functionType gr2 "foo")
|
|
|
|
both @gr1@ and @gr2@ will refer to the new grammar which contains
|
|
the new function @foo@.
|
|
-}
|
|
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 PGF a -> IO PGF
|
|
branchPGF p name t =
|
|
withText name $ \c_name ->
|
|
branchPGF_ c_name p t
|
|
|
|
branchPGF_ :: Ptr PgfText -> PGF -> Transaction PGF a -> IO PGF
|
|
branchPGF_ c_name p (Transaction f) =
|
|
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
|
|
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))
|
|
`catch`
|
|
(\e -> do
|
|
pgf_free_revision_ (a_db p) c_revision
|
|
throwIO (e :: SomeException)))
|
|
ex_type <- (#peek PgfExn, type) c_exn
|
|
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
|
|
then do pgf_commit_revision (a_db p) c_revision c_exn
|
|
ex_type <- (#peek PgfExn, type) c_exn
|
|
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
|
|
then do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
|
|
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
|
|
return p
|
|
else return p
|
|
|
|
{- | Retrieves the branch with the given name -}
|
|
checkoutPGF :: PGF -> String -> IO (Maybe PGF)
|
|
checkoutPGF p name =
|
|
withText name $ \c_name -> do
|
|
c_revision <- withPgfExn "checkoutPGF" (pgf_checkout_revision (a_db p) c_name)
|
|
if c_revision == nullPtr
|
|
then return Nothing
|
|
else do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
|
|
langs <- getConcretes (a_db p) fptr
|
|
return (Just (PGF (a_db p) fptr langs))
|
|
|
|
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 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 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 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
|
|
|
|
createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
|
|
createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
|
|
withText name $ \c_name -> do
|
|
bracket (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
|
|
|
|
alterConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
|
|
alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr 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_abstr 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 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
|
|
type LVar = Int
|
|
data LParam = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
|
|
deriving (Eq,Show)
|
|
|
|
data Symbol
|
|
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
|
|
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
|
|
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
|
|
| SymKS Token
|
|
| SymKP [Symbol] [([Symbol],[String])]
|
|
| SymBIND -- the special BIND token
|
|
| SymNE -- non exist
|
|
| SymSOFT_BIND -- the special SOFT_BIND token
|
|
| SymSOFT_SPACE -- the special SOFT_SPACE token
|
|
| SymCAPIT -- the special CAPIT token
|
|
| SymALL_CAPIT -- the special ALL_CAPIT token
|
|
deriving (Eq,Show)
|
|
|
|
data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
|
|
deriving (Eq,Show)
|
|
|
|
data Production = Production [PArg] LParam [[Symbol]]
|
|
deriving (Eq,Show)
|
|
|
|
createLincat :: Cat -> [String] -> Transaction Concr ()
|
|
createLincat name fields = Transaction $ \c_db c_abstr c_revision c_exn ->
|
|
let n_fields = length fields
|
|
in withText name $ \c_name ->
|
|
allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
|
|
withTexts c_fields 0 fields $
|
|
pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral n_fields) c_fields c_exn
|
|
where
|
|
withTexts p i [] f = f
|
|
withTexts p i (s:ss) f =
|
|
withText s $ \c_s -> do
|
|
pokeElemOff p i c_s
|
|
withTexts p (i+1) ss f
|
|
|
|
dropLincat :: Cat -> Transaction Concr ()
|
|
dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
|
|
withText name $ \c_name ->
|
|
pgf_drop_lincat c_db c_revision c_name c_exn
|
|
|
|
createLin :: Fun -> [Production] -> Transaction Concr ()
|
|
createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn ->
|
|
withText name $ \c_name ->
|
|
allocaBytes (#size PgfBuildLinIface) $ \c_build ->
|
|
allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
|
|
bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
|
|
(#poke PgfBuildLinIface, vtbl) c_build vtbl
|
|
(#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
|
|
pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
|
|
where
|
|
forM_ [] c_exn f = return ()
|
|
forM_ (x:xs) c_exn f = do
|
|
ex_type <- (#peek PgfExn, type) c_exn
|
|
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
|
|
then f x >> forM_ xs c_exn f
|
|
else return ()
|
|
|
|
build _ c_builder c_exn = do
|
|
vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder
|
|
forM_ prods c_exn $ \(Production args res seqs) -> do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl
|
|
forM_ args c_exn $ \(PArg _ param) ->
|
|
callLParam (callLinBuilder3 fun c_builder) param c_exn
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl
|
|
callLParam (callLinBuilder3 fun c_builder) res c_exn
|
|
forM_ seqs c_exn $ \syms -> do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
|
|
callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
|
|
mapM_ (addSymbol c_builder vtbl c_exn) syms
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
|
|
addSymbol c_builder vtbl c_exn (SymCat d r) = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcat) vtbl
|
|
callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn
|
|
addSymbol c_builder vtbl c_exn (SymLit d r) = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symlit) vtbl
|
|
callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn
|
|
addSymbol c_builder vtbl c_exn (SymVar d r) = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl
|
|
callLinBuilder2 fun c_builder (fromIntegral d) (fromIntegral r) c_exn
|
|
addSymbol c_builder vtbl c_exn (SymKS tok) = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl
|
|
withText tok $ \c_tok ->
|
|
callLinBuilder5 fun c_builder c_tok c_exn
|
|
addSymbol c_builder vtbl c_exn SymBIND = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symbind) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
addSymbol c_builder vtbl c_exn SymSOFT_BIND = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symsoftbind) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
addSymbol c_builder vtbl c_exn SymNE = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symne) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
addSymbol c_builder vtbl c_exn SymSOFT_SPACE = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symsoftspace) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
addSymbol c_builder vtbl c_exn SymCAPIT = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcapit) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
addSymbol c_builder vtbl c_exn SymALL_CAPIT = do
|
|
fun <- (#peek PgfLinBuilderIfaceVtbl, add_symallcapit) vtbl
|
|
callLinBuilder0 fun c_builder c_exn
|
|
|
|
callLParam f (LParam i0 terms) c_exn =
|
|
allocaBytes (n_terms*2*(#size size_t)) $ \c_terms -> do
|
|
pokeTerms c_terms terms
|
|
f (fromIntegral i0) (fromIntegral n_terms) c_terms c_exn
|
|
where
|
|
n_terms = length terms
|
|
|
|
pokeTerms c_terms [] = return ()
|
|
pokeTerms c_terms ((factor,var):terms) = do
|
|
pokeElemOff c_terms 0 (fromIntegral factor)
|
|
pokeElemOff c_terms 1 (fromIntegral var)
|
|
pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
|
|
|
|
dropLin :: Fun -> Transaction Concr ()
|
|
dropLin name = Transaction $ \c_db _ c_revision c_exn ->
|
|
withText name $ \c_name ->
|
|
pgf_drop_lin c_db c_revision c_name c_exn
|