forked from GitHub/gf-core
936 lines
41 KiB
Haskell
936 lines
41 KiB
Haskell
{-# LANGUAGE ImplicitParams, RankNTypes #-}
|
|
|
|
module PGF2.Internal(-- * Access the internal structures
|
|
FId,isPredefFId,
|
|
FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..),
|
|
globalFlags, abstrFlags, concrFlags,
|
|
concrTotalCats, concrCategories, concrProductions,
|
|
concrTotalFuns, concrFunction,
|
|
concrTotalSeqs, concrSequence,
|
|
|
|
-- * Building new PGFs in memory
|
|
build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo,
|
|
AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
|
|
|
|
-- * Expose PGF and Concr for FFI with C
|
|
PGF(..), Concr(..),
|
|
|
|
-- * Write an in-memory PGF to a file
|
|
writePGF
|
|
) where
|
|
|
|
#include <pgf/data.h>
|
|
|
|
import PGF2
|
|
import PGF2.FFI
|
|
import PGF2.Expr
|
|
import PGF2.Type
|
|
import System.IO.Unsafe(unsafePerformIO)
|
|
import Foreign
|
|
import Foreign.C
|
|
import Data.IORef
|
|
import Data.Maybe(fromMaybe)
|
|
import Data.List(sortBy)
|
|
import Control.Exception(Exception,throwIO)
|
|
import Control.Monad(foldM)
|
|
import qualified Data.Map as Map
|
|
|
|
type Token = String
|
|
data Symbol
|
|
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
|
|
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
|
|
| 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,Ord,Show)
|
|
data Production
|
|
= PApply {-# UNPACK #-} !FunId [PArg]
|
|
| PCoerce {-# UNPACK #-} !FId
|
|
deriving (Eq,Ord,Show)
|
|
data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
|
|
type FunId = Int
|
|
type SeqId = Int
|
|
data Literal =
|
|
LStr String -- ^ a string constant
|
|
| LInt Int -- ^ an integer constant
|
|
| LFlt Double -- ^ a floating point constant
|
|
deriving (Eq,Ord,Show)
|
|
|
|
|
|
-----------------------------------------------------------------------
|
|
-- Access the internal structures
|
|
-----------------------------------------------------------------------
|
|
|
|
globalFlags :: PGF -> [(String,Literal)]
|
|
globalFlags p = unsafePerformIO $ do
|
|
c_flags <- (#peek PgfPGF, gflags) (pgf p)
|
|
flags <- peekFlags c_flags
|
|
touchPGF p
|
|
return flags
|
|
|
|
abstrFlags :: PGF -> [(String,Literal)]
|
|
abstrFlags p = unsafePerformIO $ do
|
|
c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p)
|
|
flags <- peekFlags c_flags
|
|
touchPGF p
|
|
return flags
|
|
|
|
concrFlags :: Concr -> [(String,Literal)]
|
|
concrFlags c = unsafePerformIO $ do
|
|
c_flags <- (#peek PgfConcr, cflags) (concr c)
|
|
flags <- peekFlags c_flags
|
|
touchConcr c
|
|
return flags
|
|
|
|
peekFlags :: Ptr GuSeq -> IO [(String,Literal)]
|
|
peekFlags c_flags = do
|
|
c_len <- (#peek GuSeq, len) c_flags
|
|
peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data))
|
|
where
|
|
peekFlags 0 ptr = return []
|
|
peekFlags c_len ptr = do
|
|
name <- (#peek PgfFlag, name) ptr >>= peekUtf8CString
|
|
value <- (#peek PgfFlag, value) ptr >>= peekLiteral
|
|
flags <- peekFlags (c_len-1) (ptr `plusPtr` (#size PgfFlag))
|
|
return ((name,value):flags)
|
|
|
|
peekLiteral :: GuVariant -> IO Literal
|
|
peekLiteral p = do
|
|
tag <- gu_variant_tag p
|
|
ptr <- gu_variant_data p
|
|
case tag of
|
|
(#const PGF_LITERAL_STR) -> do { val <- peekUtf8CString (ptr `plusPtr` (#offset PgfLiteralStr, val));
|
|
return (LStr val) }
|
|
(#const PGF_LITERAL_INT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralInt, val));
|
|
return (LInt (fromIntegral (val :: CInt))) }
|
|
(#const PGF_LITERAL_FLT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralFlt, val));
|
|
return (LFlt (realToFrac (val :: CDouble))) }
|
|
_ -> error "Unknown literal type in the grammar"
|
|
|
|
concrTotalCats :: Concr -> FId
|
|
concrTotalCats c = unsafePerformIO $ do
|
|
c_total_cats <- (#peek PgfConcr, total_cats) (concr c)
|
|
touchConcr c
|
|
return (fromIntegral (c_total_cats :: CInt))
|
|
|
|
concrCategories :: Concr -> [(Cat,FId,FId,[String])]
|
|
concrCategories c =
|
|
unsafePerformIO $
|
|
withGuPool $ \tmpPl ->
|
|
allocaBytes (#size GuMapItor) $ \itor -> do
|
|
exn <- gu_new_exn tmpPl
|
|
ref <- newIORef []
|
|
fptr <- wrapMapItorCallback (getCategories ref)
|
|
(#poke GuMapItor, fn) itor fptr
|
|
c_cnccats <- (#peek PgfConcr, cnccats) (concr c)
|
|
gu_map_iter c_cnccats itor exn
|
|
touchConcr c
|
|
freeHaskellFunPtr fptr
|
|
cs <- readIORef ref
|
|
return (reverse cs)
|
|
where
|
|
getCategories ref itor key value exn = do
|
|
names <- readIORef ref
|
|
name <- peekUtf8CString (castPtr key)
|
|
c_cnccat <- peek (castPtr value)
|
|
c_cats <- (#peek PgfCncCat, cats) c_cnccat
|
|
c_len <- (#peek GuSeq, len) c_cats
|
|
first <- peek (c_cats `plusPtr` (#offset GuSeq, data)) >>= peekFId
|
|
last <- peek (c_cats `plusPtr` ((#offset GuSeq, data) + (fromIntegral (c_len-1::CSizeT))*(#size PgfCCat*))) >>= peekFId
|
|
c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat
|
|
arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` (#offset PgfCncCat, labels))
|
|
labels <- mapM peekUtf8CString arr
|
|
writeIORef ref ((name,first,last,labels) : names)
|
|
|
|
concrProductions :: Concr -> FId -> [Production]
|
|
concrProductions c fid = unsafePerformIO $ do
|
|
c_ccats <- (#peek PgfConcr, ccats) (concr c)
|
|
res <- alloca $ \pfid -> do
|
|
poke pfid (fromIntegral fid :: CInt)
|
|
gu_map_find_default c_ccats pfid >>= peek
|
|
if res == nullPtr
|
|
then do touchConcr c
|
|
return []
|
|
else do c_prods <- (#peek PgfCCat, prods) res
|
|
if c_prods == nullPtr
|
|
then do touchConcr c
|
|
return []
|
|
else do res <- peekSequence (deRef peekProduction) (#size GuVariant) c_prods
|
|
touchConcr c
|
|
return res
|
|
where
|
|
peekProduction p = do
|
|
tag <- gu_variant_tag p
|
|
dt <- gu_variant_data p
|
|
case tag of
|
|
(#const PGF_PRODUCTION_APPLY) -> do { c_cncfun <- (#peek PgfProductionApply, fun) dt ;
|
|
c_funid <- (#peek PgfCncFun, funid) c_cncfun ;
|
|
c_args <- (#peek PgfProductionApply, args) dt ;
|
|
pargs <- peekSequence peekPArg (#size PgfPArg) c_args ;
|
|
return (PApply (fromIntegral (c_funid :: CInt)) pargs) }
|
|
(#const PGF_PRODUCTION_COERCE)-> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ;
|
|
fid <- peekFId c_coerce ;
|
|
return (PCoerce fid) }
|
|
_ -> error "Unknown production type in the grammar"
|
|
where
|
|
peekPArg ptr = do
|
|
c_hypos <- (#peek PgfPArg, hypos) ptr
|
|
hypos <- peekSequence (deRef peekFId) (#size int) c_hypos
|
|
c_ccat <- (#peek PgfPArg, ccat) ptr
|
|
fid <- peekFId c_ccat
|
|
return (PArg hypos fid)
|
|
|
|
peekFId c_ccat = do
|
|
c_fid <- (#peek PgfCCat, fid) c_ccat
|
|
return (fromIntegral (c_fid :: CInt))
|
|
|
|
concrTotalFuns :: Concr -> FunId
|
|
concrTotalFuns c = unsafePerformIO $ do
|
|
c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
|
|
c_len <- (#peek GuSeq, len) c_cncfuns
|
|
touchConcr c
|
|
return (fromIntegral (c_len :: CSizeT))
|
|
|
|
concrFunction :: Concr -> FunId -> (Fun,[SeqId])
|
|
concrFunction c funid = unsafePerformIO $ do
|
|
c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
|
|
c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*)))
|
|
c_absfun <- (#peek PgfCncFun, absfun) c_cncfun
|
|
c_name <- (#peek PgfAbsFun, name) c_absfun
|
|
name <- peekUtf8CString c_name
|
|
c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun
|
|
arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins))
|
|
seqs_seq <- (#peek PgfConcr, sequences) (concr c)
|
|
touchConcr c
|
|
let seqs = seqs_seq `plusPtr` (#offset GuSeq, data)
|
|
return (name, map (toSeqId seqs) arr)
|
|
where
|
|
toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence)
|
|
|
|
concrTotalSeqs :: Concr -> SeqId
|
|
concrTotalSeqs c = unsafePerformIO $ do
|
|
seq <- (#peek PgfConcr, sequences) (concr c)
|
|
c_len <- (#peek GuSeq, len) seq
|
|
touchConcr c
|
|
return (fromIntegral (c_len :: CSizeT))
|
|
|
|
concrSequence :: Concr -> SeqId -> [Symbol]
|
|
concrSequence c seqid = unsafePerformIO $ do
|
|
c_sequences <- (#peek PgfConcr, sequences) (concr c)
|
|
let c_sequence = c_sequences `plusPtr` ((#offset GuSeq, data)+seqid*(#size PgfSequence))
|
|
c_syms <- (#peek PgfSequence, syms) c_sequence
|
|
res <- peekSequence (deRef peekSymbol) (#size GuVariant) c_syms
|
|
touchConcr c
|
|
return res
|
|
where
|
|
peekSymbol p = do
|
|
tag <- gu_variant_tag p
|
|
dt <- gu_variant_data p
|
|
case tag of
|
|
(#const PGF_SYMBOL_CAT) -> peekSymbolIdx SymCat dt
|
|
(#const PGF_SYMBOL_LIT) -> peekSymbolIdx SymLit dt
|
|
(#const PGF_SYMBOL_VAR) -> peekSymbolIdx SymVar dt
|
|
(#const PGF_SYMBOL_KS) -> peekSymbolKS dt
|
|
(#const PGF_SYMBOL_KP) -> peekSymbolKP dt
|
|
(#const PGF_SYMBOL_BIND) -> return SymBIND
|
|
(#const PGF_SYMBOL_SOFT_BIND) -> return SymSOFT_BIND
|
|
(#const PGF_SYMBOL_NE) -> return SymNE
|
|
(#const PGF_SYMBOL_SOFT_SPACE) -> return SymSOFT_SPACE
|
|
(#const PGF_SYMBOL_CAPIT) -> return SymCAPIT
|
|
(#const PGF_SYMBOL_ALL_CAPIT) -> return SymALL_CAPIT
|
|
_ -> error "Unknown symbol type in the grammar"
|
|
|
|
peekSymbolIdx constr dt = do
|
|
c_d <- (#peek PgfSymbolIdx, d) dt
|
|
c_r <- (#peek PgfSymbolIdx, r) dt
|
|
return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt)))
|
|
|
|
peekSymbolKS dt = do
|
|
token <- peekUtf8CString (dt `plusPtr` (#offset PgfSymbolKS, token))
|
|
return (SymKS token)
|
|
|
|
peekSymbolKP dt = do
|
|
c_default_form <- (#peek PgfSymbolKP, default_form) dt
|
|
default_form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_default_form
|
|
c_n_forms <- (#peek PgfSymbolKP, n_forms) dt
|
|
forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` (#offset PgfSymbolKP, forms))
|
|
return (SymKP default_form forms)
|
|
|
|
peekForms 0 ptr = return []
|
|
peekForms len ptr = do
|
|
c_form <- (#peek PgfAlternative, form) ptr
|
|
form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_form
|
|
c_prefixes <- (#peek PgfAlternative, prefixes) ptr
|
|
prefixes <- peekSequence (deRef peekUtf8CString) (#size GuString*) c_prefixes
|
|
forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative))
|
|
return ((form,prefixes):forms)
|
|
|
|
deRef peekValue ptr = peek ptr >>= peekValue
|
|
|
|
fidString, fidInt, fidFloat, fidVar, fidStart :: FId
|
|
fidString = (-1)
|
|
fidInt = (-2)
|
|
fidFloat = (-3)
|
|
fidVar = (-4)
|
|
fidStart = (-5)
|
|
|
|
isPredefFId :: FId -> Bool
|
|
isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])
|
|
|
|
|
|
-----------------------------------------------------------------------
|
|
-- Building new PGFs in memory
|
|
-----------------------------------------------------------------------
|
|
|
|
data Builder s = Builder (Ptr GuPool) Touch
|
|
newtype B s a = B a
|
|
|
|
build :: (forall s . (?builder :: Builder s) => B s a) -> a
|
|
build f =
|
|
unsafePerformIO $ do
|
|
pool <- gu_new_pool
|
|
poolFPtr <- newForeignPtr gu_pool_finalizer pool
|
|
let ?builder = Builder pool (touchForeignPtr poolFPtr)
|
|
let B res = f
|
|
return res
|
|
|
|
eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr
|
|
eAbs bind_type var (B (Expr body _)) =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_ABS)
|
|
(#size PgfExprAbs)
|
|
(#const gu_alignof(PgfExprAbs))
|
|
pptr pool
|
|
cvar <- newUtf8CString var pool
|
|
(#poke PgfExprAbs, bind_type) ptr (cbind_type :: PgfBindType)
|
|
(#poke PgfExprAbs, id) ptr cvar
|
|
(#poke PgfExprAbs, body) ptr body
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
cbind_type =
|
|
case bind_type of
|
|
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
|
|
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
|
|
|
|
eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr
|
|
eApp (B (Expr fun _)) (B (Expr arg _)) =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_APP)
|
|
(#size PgfExprApp)
|
|
(#const gu_alignof(PgfExprApp))
|
|
pptr pool
|
|
(#poke PgfExprApp, fun) ptr fun
|
|
(#poke PgfExprApp, arg) ptr arg
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
eMeta :: (?builder :: Builder s) => Int -> B s Expr
|
|
eMeta id =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_META)
|
|
(fromIntegral (#size PgfExprMeta))
|
|
(#const gu_alignof(PgfExprMeta))
|
|
pptr pool
|
|
(#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt)
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
eFun :: (?builder :: Builder s) => Fun -> B s Expr
|
|
eFun fun =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_FUN)
|
|
(fromIntegral ((#size PgfExprFun)+utf8Length fun))
|
|
(#const gu_flex_alignof(PgfExprFun))
|
|
pptr pool
|
|
pokeUtf8CString fun (ptr `plusPtr` (#offset PgfExprFun, fun))
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
eVar :: (?builder :: Builder s) => Int -> B s Expr
|
|
eVar var =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_VAR)
|
|
(#size PgfExprVar)
|
|
(#const gu_alignof(PgfExprVar))
|
|
pptr pool
|
|
(#poke PgfExprVar, var) ptr (fromIntegral var :: CInt)
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr
|
|
eTyped (B (Expr e _)) (B (Type ty _)) =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_TYPED)
|
|
(#size PgfExprTyped)
|
|
(#const gu_alignof(PgfExprTyped))
|
|
pptr pool
|
|
(#poke PgfExprTyped, expr) ptr e
|
|
(#poke PgfExprTyped, type) ptr ty
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr
|
|
eImplArg (B (Expr e _)) =
|
|
unsafePerformIO $
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_EXPR_IMPL_ARG)
|
|
(#size PgfExprImplArg)
|
|
(#const gu_alignof(PgfExprImplArg))
|
|
pptr pool
|
|
(#poke PgfExprImplArg, expr) ptr e
|
|
e <- peek pptr
|
|
return (B (Expr e touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
hypo :: BindType -> CId -> B s Type -> (B s Hypo)
|
|
hypo bind_type var (B ty) = B (bind_type,var,ty)
|
|
|
|
dTyp :: (?builder :: Builder s) => [B s Hypo] -> Cat -> [B s Expr] -> B s Type
|
|
dTyp hypos cat es =
|
|
unsafePerformIO $ do
|
|
ptr <- gu_malloc_aligned pool
|
|
((#size PgfType)+n_exprs*(#size GuVariant))
|
|
(#const gu_flex_alignof(PgfType))
|
|
c_hypos <- newHypos hypos pool
|
|
c_cat <- newUtf8CString cat pool
|
|
(#poke PgfType, hypos) ptr c_hypos
|
|
(#poke PgfType, cid) ptr c_cat
|
|
(#poke PgfType, n_exprs) ptr n_exprs
|
|
pokeArray (ptr `plusPtr` (#offset PgfType, exprs)) [e | B (Expr e _) <- es]
|
|
return (B (Type ptr touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
n_exprs = fromIntegral (length es) :: CSizeT
|
|
|
|
newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq)
|
|
newHypos hypos pool = do
|
|
c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool
|
|
pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos
|
|
return c_hypos
|
|
where
|
|
pokeHypos ptr [] = return ()
|
|
pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do
|
|
c_var <- newUtf8CString var pool
|
|
(#poke PgfHypo, bind_type) ptr (cbind_type :: PgfBindType)
|
|
(#poke PgfHypo, cid) ptr c_var
|
|
(#poke PgfHypo, type) ptr ty
|
|
pokeHypos (ptr `plusPtr` (#size PgfHypo)) hypos
|
|
where
|
|
cbind_type =
|
|
case bind_type of
|
|
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
|
|
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
|
|
|
|
|
|
data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch
|
|
|
|
newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
|
|
[(Cat,[B s Hypo],Float)] ->
|
|
[(Fun,B s Type,Int,Float)] ->
|
|
AbstrInfo
|
|
newAbstr aflags cats funs = unsafePerformIO $ do
|
|
c_aflags <- newFlags aflags pool
|
|
(c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
|
|
(c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
|
|
c_abs_lin_fun <- newAbsLinFun
|
|
c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool
|
|
return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch)
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
newAbsCats values pool = do
|
|
c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool
|
|
abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values
|
|
return (c_seq,abscats)
|
|
where
|
|
pokeElems ptr abscats [] = return abscats
|
|
pokeElems ptr abscats (x:xs) = do
|
|
abscats <- pokeAbsCat ptr abscats x
|
|
pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs
|
|
|
|
pokeAbsCat ptr abscats (name,hypos,prob) = do
|
|
c_name <- newUtf8CString name pool
|
|
c_hypos <- newHypos hypos pool
|
|
(#poke PgfAbsCat, name) ptr c_name
|
|
(#poke PgfAbsCat, context) ptr c_hypos
|
|
(#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat)
|
|
return (Map.insert name ptr abscats)
|
|
|
|
newAbsFuns values pool = do
|
|
c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool
|
|
absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values
|
|
return (c_seq,absfuns)
|
|
where
|
|
pokeElems ptr absfuns [] = return absfuns
|
|
pokeElems ptr absfuns (x:xs) = do
|
|
absfuns <- pokeAbsFun ptr absfuns x
|
|
pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs
|
|
|
|
pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do
|
|
pfun <- gu_alloc_variant (#const PGF_EXPR_FUN)
|
|
(fromIntegral ((#size PgfExprFun)+utf8Length name))
|
|
(#const gu_flex_alignof(PgfExprFun))
|
|
(ptr `plusPtr` (#offset PgfAbsFun, ep.expr)) pool
|
|
let c_name = (pfun `plusPtr` (#offset PgfExprFun, fun))
|
|
pokeUtf8CString name c_name
|
|
(#poke PgfAbsFun, name) ptr c_name
|
|
(#poke PgfAbsFun, type) ptr c_ty
|
|
(#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt)
|
|
(#poke PgfAbsFun, defns) ptr nullPtr
|
|
(#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat)
|
|
return (Map.insert name ptr absfuns)
|
|
|
|
newAbsLinFun = do
|
|
ptr <- gu_malloc_aligned pool
|
|
(#size PgfAbsFun)
|
|
(#const gu_alignof(PgfAbsFun))
|
|
c_wild <- newUtf8CString "_" pool
|
|
c_ty <- gu_malloc_aligned pool
|
|
(#size PgfType)
|
|
(#const gu_alignof(PgfType))
|
|
(#poke PgfType, hypos) c_ty nullPtr
|
|
(#poke PgfType, cid) c_ty c_wild
|
|
(#poke PgfType, n_exprs) c_ty (0 :: CSizeT)
|
|
(#poke PgfAbsFun, name) ptr c_wild
|
|
(#poke PgfAbsFun, type) ptr c_ty
|
|
(#poke PgfAbsFun, arity) ptr (0 :: CSizeT)
|
|
(#poke PgfAbsFun, defns) ptr nullPtr
|
|
(#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat)
|
|
(#poke PgfAbsFun, ep.expr) ptr nullPtr
|
|
return ptr
|
|
|
|
|
|
data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt
|
|
|
|
newConcr :: (?builder :: Builder s) => AbstrInfo ->
|
|
[(String,Literal)] -> -- ^ Concrete syntax flags
|
|
[(String,String)] -> -- ^ Printnames
|
|
[(FId,[FunId])] -> -- ^ Lindefs
|
|
[(FId,[FunId])] -> -- ^ Linrefs
|
|
[(FId,[Production])] -> -- ^ Productions
|
|
[(Fun,[SeqId])] -> -- ^ Concrete functions (must be sorted by Fun)
|
|
[[Symbol]] -> -- ^ Sequences (must be sorted)
|
|
[(Cat,FId,FId,[String])] -> -- ^ Concrete categories
|
|
FId -> -- ^ The total count of the categories
|
|
ConcrInfo
|
|
newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do
|
|
c_cflags <- newFlags cflags pool
|
|
c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString
|
|
(#size GuString) (pokeString pool)
|
|
printnames pool
|
|
c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool
|
|
let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data)
|
|
c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool
|
|
let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data)
|
|
c_ccats <- gu_make_map (#size int) gu_int_hasher
|
|
(#size PgfCCat*) gu_null_struct
|
|
(#const GU_MAP_DEFAULT_INIT_SIZE)
|
|
pool
|
|
mapM_ (addLindefs c_ccats funs_ptr) lindefs
|
|
mapM_ (addLinrefs c_ccats funs_ptr) linrefs
|
|
mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods
|
|
c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool
|
|
return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
pokeCncFun seqs_ptr ptr cncfun = do
|
|
c_cncfun <- newCncFun absfuns nullPtr cncfun pool
|
|
poke ptr c_cncfun
|
|
|
|
pokeSequence c_seq syms = do
|
|
c_syms <- newSymbols syms pool
|
|
(#poke PgfSequence, syms) c_seq c_syms
|
|
(#poke PgfSequence, idx) c_seq nullPtr
|
|
|
|
addLindefs c_ccats funs_ptr (fid,funids) = do
|
|
c_ccat <- getCCat c_ccats fid pool
|
|
c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool
|
|
(#poke PgfCCat, lindefs) c_ccat c_funs
|
|
|
|
addLinrefs c_ccats funs_ptr (fid,funids) = do
|
|
c_ccat <- getCCat c_ccats fid pool
|
|
c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool
|
|
(#poke PgfCCat, linrefs) c_ccat c_funs
|
|
|
|
addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do
|
|
c_ccat <- getCCat c_ccats fid pool
|
|
let n_prods = length prods
|
|
c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral n_prods) pool
|
|
(#poke PgfCCat, prods) c_ccat c_prods
|
|
pokeProductions c_ccat (c_prods `plusPtr` (#offset GuSeq, data)) 0 (n_prods-1) mk_index prods
|
|
where
|
|
pokeProductions c_ccat ptr top bot mk_index [] = return mk_index
|
|
pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do
|
|
(is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool
|
|
let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool
|
|
pgf_lzr_index concr c_ccat c_prod is_lexical pool
|
|
mk_index concr pool
|
|
if is_lexical == 0
|
|
then do poke (ptr `plusPtr` ((#size PgfProduction)*top)) c_prod
|
|
pokeProductions c_ccat ptr (top+1) bot mk_index' prods
|
|
else do poke (ptr `plusPtr` ((#size PgfProduction)*bot)) c_prod
|
|
pokeProductions c_ccat ptr top (bot-1) mk_index' prods
|
|
|
|
pokeRefDefFunId funs_ptr ptr funid = do
|
|
let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun))
|
|
(#poke PgfCncFun, absfun) c_fun c_abs_lin_fun
|
|
poke ptr c_fun
|
|
|
|
pokeCncCat c_ccats ptr (name,start,end,labels) = do
|
|
let n_lins = fromIntegral (length labels) :: CSizeT
|
|
c_cnccat <- gu_malloc_aligned pool
|
|
((#size PgfCncCat)+n_lins*(#size GuString))
|
|
(#const gu_flex_alignof(PgfCncCat))
|
|
case Map.lookup name abscats of
|
|
Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat
|
|
Nothing -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax"))
|
|
c_ccats <- newSequence (#size PgfCCat*) pokeFId [start..end] pool
|
|
(#poke PgfCncCat, cats) c_cnccat c_ccats
|
|
pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels
|
|
poke ptr c_cnccat
|
|
where
|
|
pokeFId ptr fid = do
|
|
c_ccat <- getCCat c_ccats fid pool
|
|
poke ptr c_ccat
|
|
|
|
pokeLabels ptr [] = return []
|
|
pokeLabels ptr (l:ls) = do
|
|
c_l <- newUtf8CString l pool
|
|
poke ptr c_l
|
|
pokeLabels (ptr `plusPtr` (#size GuString)) ls
|
|
|
|
|
|
newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
|
|
AbsName ->
|
|
AbstrInfo ->
|
|
[(ConcName,ConcrInfo)] ->
|
|
B s PGF
|
|
newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs =
|
|
unsafePerformIO $ do
|
|
ptr <- gu_malloc_aligned pool
|
|
(#size PgfPGF)
|
|
(#const gu_alignof(PgfPGF))
|
|
c_gflags <- newFlags gflags pool
|
|
c_absname <- newUtf8CString absname pool
|
|
let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract)
|
|
c_concrs <- newSequence (#size PgfConcr) (pokeConcr c_abstr) concrs pool
|
|
(#poke PgfPGF, major_version) ptr (2 :: (#type uint16_t))
|
|
(#poke PgfPGF, minor_version) ptr (0 :: (#type uint16_t))
|
|
(#poke PgfPGF, gflags) ptr c_gflags
|
|
(#poke PgfPGF, abstract.name) ptr c_absname
|
|
(#poke PgfPGF, abstract.aflags) ptr c_aflags
|
|
(#poke PgfPGF, abstract.funs) ptr c_funs
|
|
(#poke PgfPGF, abstract.cats) ptr c_cats
|
|
(#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun
|
|
(#poke PgfPGF, concretes) ptr c_concrs
|
|
(#poke PgfPGF, pool) ptr pool
|
|
return (B (PGF ptr touch))
|
|
where
|
|
(Builder pool touch) = ?builder
|
|
|
|
pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do
|
|
c_name <- newUtf8CString name pool
|
|
c_fun_indices <- gu_make_map (#size GuString) gu_string_hasher
|
|
(#size PgfCncOverloadMap*) gu_null_struct
|
|
(#const GU_MAP_DEFAULT_INIT_SIZE)
|
|
pool
|
|
c_coerce_idx <- gu_make_map (#size PgfCCat*) gu_addr_hasher
|
|
(#size GuBuf*) gu_null_struct
|
|
(#const GU_MAP_DEFAULT_INIT_SIZE)
|
|
pool
|
|
(#poke PgfConcr, name) ptr c_name
|
|
(#poke PgfConcr, abstr) ptr c_abstr
|
|
(#poke PgfConcr, cflags) ptr c_cflags
|
|
(#poke PgfConcr, printnames) ptr c_printnames
|
|
(#poke PgfConcr, ccats) ptr c_ccats
|
|
(#poke PgfConcr, fun_indices) ptr c_fun_indices
|
|
(#poke PgfConcr, coerce_idx) ptr c_coerce_idx
|
|
(#poke PgfConcr, cncfuns) ptr c_cncfuns
|
|
(#poke PgfConcr, sequences) ptr c_seqs
|
|
(#poke PgfConcr, cnccats) ptr c_cnccats
|
|
(#poke PgfConcr, total_cats) ptr c_total_cats
|
|
(#poke PgfConcr, pool) ptr nullPtr
|
|
mk_index ptr pool
|
|
|
|
|
|
newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq)
|
|
newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool
|
|
where
|
|
pokeFlag c_flag (name,value) = do
|
|
c_name <- newUtf8CString name pool
|
|
c_value <- newLiteral value pool
|
|
(#poke PgfFlag, name) c_flag c_name
|
|
(#poke PgfFlag, value) c_flag c_value
|
|
|
|
|
|
newLiteral :: Literal -> Ptr GuPool -> IO GuVariant
|
|
newLiteral (LStr val) pool =
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_LITERAL_STR)
|
|
(fromIntegral ((#size PgfLiteralStr)+utf8Length val))
|
|
(#const gu_flex_alignof(PgfLiteralStr))
|
|
pptr pool
|
|
pokeUtf8CString val (ptr `plusPtr` (#offset PgfLiteralStr, val))
|
|
peek pptr
|
|
newLiteral (LInt val) pool =
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_LITERAL_INT)
|
|
(fromIntegral (#size PgfLiteralInt))
|
|
(#const gu_alignof(PgfLiteralInt))
|
|
pptr pool
|
|
(#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt)
|
|
peek pptr
|
|
newLiteral (LFlt val) pool =
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT)
|
|
(fromIntegral (#size PgfLiteralFlt))
|
|
(#const gu_alignof(PgfLiteralFlt))
|
|
pptr pool
|
|
(#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble)
|
|
peek pptr
|
|
|
|
|
|
newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((#type bool), GuVariant)
|
|
newProduction c_ccats funs_ptr c_non_lexical_buf (PApply fun_id args) pool =
|
|
alloca $ \pptr -> do
|
|
let c_fun = funs_ptr `plusPtr` (fun_id * (#size PgfCncFun))
|
|
c_args <- newSequence (#size PgfPArg) pokePArg args pool
|
|
ptr <- gu_alloc_variant (#const PGF_PRODUCTION_APPLY)
|
|
(fromIntegral (#size PgfProductionApply))
|
|
(#const gu_alignof(PgfProductionApply))
|
|
pptr pool
|
|
(#poke PgfProductionApply, fun) ptr c_fun
|
|
(#poke PgfProductionApply, args) ptr c_args
|
|
is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool
|
|
c_prod <- peek pptr
|
|
return (is_lexical,c_prod)
|
|
where
|
|
pokePArg ptr (PArg hypos ccat) = do
|
|
c_ccat <- getCCat c_ccats ccat pool
|
|
(#poke PgfPArg, ccat) ptr c_ccat
|
|
c_hypos <- newSequence (#size PgfCCat*) pokeCCat hypos pool
|
|
(#poke PgfPArg, hypos) ptr c_hypos
|
|
|
|
pokeCCat ptr ccat = do
|
|
c_ccat <- getCCat c_ccats ccat pool
|
|
poke ptr c_ccat
|
|
|
|
newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool =
|
|
alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_PRODUCTION_COERCE)
|
|
(fromIntegral (#size PgfProductionCoerce))
|
|
(#const gu_alignof(PgfProductionCoerce))
|
|
pptr pool
|
|
c_ccat <- getCCat c_ccats fid pool
|
|
(#poke PgfProductionCoerce, coerce) ptr c_ccat
|
|
c_prod <- peek pptr
|
|
return (0,c_prod)
|
|
|
|
|
|
newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
|
|
do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
|
|
c_ep = if c_absfun == nullPtr
|
|
then nullPtr
|
|
else c_absfun `plusPtr` (#offset PgfAbsFun, ep)
|
|
n_lins = fromIntegral (length seqids) :: CSizeT
|
|
ptr <- gu_malloc_aligned pool
|
|
((#size PgfCncFun)+n_lins*(#size PgfSequence*))
|
|
(#const gu_flex_alignof(PgfCncFun))
|
|
(#poke PgfCncFun, absfun) ptr c_absfun
|
|
(#poke PgfCncFun, ep) ptr c_ep
|
|
(#poke PgfCncFun, funid) ptr (funid :: CInt)
|
|
(#poke PgfCncFun, n_lins) ptr n_lins
|
|
pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids
|
|
return ptr
|
|
where
|
|
pokeSequences seqs_ptr ptr [] = return ()
|
|
pokeSequences seqs_ptr ptr (seqid:seqids) = do
|
|
poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence)))
|
|
pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids
|
|
|
|
getCCat c_ccats fid pool =
|
|
alloca $ \pfid -> do
|
|
poke pfid (fromIntegral fid :: CInt)
|
|
ptr <- gu_map_find_default c_ccats pfid
|
|
c_ccat <- peek ptr
|
|
if c_ccat /= nullPtr
|
|
then return c_ccat
|
|
else do c_ccat <- gu_malloc_aligned pool
|
|
(#size PgfCCat)
|
|
(#const gu_alignof(PgfCCat))
|
|
(#poke PgfCCat, cnccat) c_ccat nullPtr
|
|
(#poke PgfCCat, lindefs) c_ccat nullPtr
|
|
(#poke PgfCCat, linrefs) c_ccat nullPtr
|
|
(#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT)
|
|
(#poke PgfCCat, prods) c_ccat nullPtr
|
|
(#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat)
|
|
(#poke PgfCCat, fid) c_ccat fid
|
|
(#poke PgfCCat, conts) c_ccat nullPtr
|
|
(#poke PgfCCat, answers) c_ccat nullPtr
|
|
ptr <- gu_map_insert c_ccats pfid
|
|
poke ptr c_ccat
|
|
return c_ccat
|
|
|
|
newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
|
|
newSymbol (SymCat d r) pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT)
|
|
(fromIntegral (#size PgfSymbolCat))
|
|
(#const gu_alignof(PgfSymbolCat))
|
|
pptr pool
|
|
(#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt)
|
|
(#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt)
|
|
peek pptr
|
|
newSymbol (SymLit d r) pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT)
|
|
(fromIntegral (#size PgfSymbolLit))
|
|
(#const gu_alignof(PgfSymbolLit))
|
|
pptr pool
|
|
(#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt)
|
|
(#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt)
|
|
peek pptr
|
|
newSymbol (SymVar d r) pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR)
|
|
(fromIntegral (#size PgfSymbolVar))
|
|
(#const gu_alignof(PgfSymbolVar))
|
|
pptr pool
|
|
(#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt)
|
|
(#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt)
|
|
peek pptr
|
|
newSymbol (SymKS t) pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS)
|
|
(fromIntegral ((#size PgfSymbolKS)+utf8Length t))
|
|
(#const gu_flex_alignof(PgfSymbolKS))
|
|
pptr pool
|
|
pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token))
|
|
peek pptr
|
|
newSymbol (SymKP def alts) pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP)
|
|
(fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative))))
|
|
(#const gu_flex_alignof(PgfSymbolKP))
|
|
pptr pool
|
|
c_def <- newSymbols def pool
|
|
(#poke PgfSymbolKP, default_form) ptr c_def
|
|
pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool
|
|
peek pptr
|
|
newSymbol SymBIND pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND)
|
|
(fromIntegral (#size PgfSymbolBIND))
|
|
(#const gu_alignof(PgfSymbolBIND))
|
|
pptr pool
|
|
peek pptr
|
|
newSymbol SymNE pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE)
|
|
(fromIntegral (#size PgfSymbolNE))
|
|
(#const gu_alignof(PgfSymbolNE))
|
|
pptr pool
|
|
peek pptr
|
|
newSymbol SymSOFT_BIND pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND)
|
|
(fromIntegral (#size PgfSymbolBIND))
|
|
(#const gu_alignof(PgfSymbolBIND))
|
|
pptr pool
|
|
peek pptr
|
|
newSymbol SymSOFT_SPACE pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE)
|
|
(fromIntegral (#size PgfSymbolBIND))
|
|
(#const gu_alignof(PgfSymbolBIND))
|
|
pptr pool
|
|
peek pptr
|
|
newSymbol SymCAPIT pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT)
|
|
(fromIntegral (#size PgfSymbolCAPIT))
|
|
(#const gu_alignof(PgfSymbolCAPIT))
|
|
pptr pool
|
|
peek pptr
|
|
newSymbol SymALL_CAPIT pool = alloca $ \pptr -> do
|
|
ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT)
|
|
(fromIntegral (#size PgfSymbolCAPIT))
|
|
(#const gu_alignof(PgfSymbolCAPIT))
|
|
pptr pool
|
|
peek pptr
|
|
|
|
newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool
|
|
where
|
|
pokeSymbol p_sym sym = do
|
|
c_sym <- newSymbol sym pool
|
|
poke p_sym c_sym
|
|
|
|
pokeAlternatives ptr [] pool = return ()
|
|
pokeAlternatives ptr ((syms,prefixes):alts) pool = do
|
|
c_syms <- newSymbols syms pool
|
|
c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool
|
|
(#poke PgfAlternative, form) ptr c_syms
|
|
(#poke PgfAlternative, prefixes) ptr c_prefixes
|
|
pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool
|
|
|
|
pokeString pool c_elem str = do
|
|
c_str <- newUtf8CString str pool
|
|
poke c_elem c_str
|
|
|
|
newMap key_size hasher newKey elem_size pokeElem values pool = do
|
|
map <- gu_make_map key_size hasher
|
|
elem_size gu_null_struct
|
|
(#const GU_MAP_DEFAULT_INIT_SIZE)
|
|
pool
|
|
insert map values pool
|
|
return map
|
|
where
|
|
insert map [] pool = return ()
|
|
insert map ((key,elem):values) pool = do
|
|
c_key <- newKey key pool
|
|
c_elem <- gu_map_insert map c_key
|
|
pokeElem c_elem elem
|
|
insert map values pool
|
|
|
|
|
|
writePGF :: FilePath -> PGF -> IO ()
|
|
writePGF fpath p = do
|
|
pool <- gu_new_pool
|
|
exn <- gu_new_exn pool
|
|
withCString fpath $ \c_fpath ->
|
|
pgf_write (pgf p) c_fpath exn
|
|
touchPGF p
|
|
failed <- gu_exn_is_raised exn
|
|
if failed
|
|
then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno
|
|
if is_errno
|
|
then do perrno <- (#peek GuExn, data.data) exn
|
|
errno <- peek perrno
|
|
gu_pool_free pool
|
|
ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath))
|
|
else do gu_pool_free pool
|
|
throwIO (PGFError "The grammar cannot be stored")
|
|
else do gu_pool_free pool
|
|
return ()
|
|
|
|
sortByFst = sortBy (\(x,_) (y,_) -> compare x y)
|
|
sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y)
|
|
sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y)
|