forked from GitHub/gf-core
an almost complete API for building new PGF files in the Haskell binding
This commit is contained in:
Krasimir Angelov
@@ -29,13 +29,14 @@ data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch}
|
||||
data GuEnum
|
||||
data GuExn
|
||||
data GuIn
|
||||
data GuOut
|
||||
data GuKind
|
||||
data GuType
|
||||
data GuString
|
||||
data GuStringBuf
|
||||
data GuMap
|
||||
data GuMapItor
|
||||
data GuOut
|
||||
data GuHasher
|
||||
data GuSeq
|
||||
data GuPool
|
||||
type GuVariant = Ptr ()
|
||||
@@ -111,12 +112,27 @@ foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
|
||||
foreign import ccall unsafe "gu/seq.h gu_make_seq"
|
||||
gu_make_seq :: CSizeT -> CSizeT -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
|
||||
foreign import ccall unsafe "gu/map.h gu_make_map"
|
||||
gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap)
|
||||
|
||||
foreign import ccall unsafe "gu/map.h gu_map_insert"
|
||||
gu_map_insert :: Ptr GuMap -> Ptr a -> IO (Ptr b)
|
||||
|
||||
foreign import ccall unsafe "gu/map.h gu_map_find_default"
|
||||
gu_map_find_default :: Ptr GuMap -> Ptr a -> IO (Ptr b)
|
||||
|
||||
foreign import ccall "gu/map.h gu_map_iter"
|
||||
gu_map_iter :: Ptr GuMap -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall unsafe "gu/hash.h &gu_int_hasher"
|
||||
gu_int_hasher :: Ptr GuHasher
|
||||
|
||||
foreign import ccall unsafe "gu/hash.h &gu_string_hasher"
|
||||
gu_string_hasher :: Ptr GuHasher
|
||||
|
||||
foreign import ccall unsafe "gu/hash.h &gu_null_struct"
|
||||
gu_null_struct :: Ptr a
|
||||
|
||||
foreign import ccall unsafe "gu/variant.h gu_variant_tag"
|
||||
gu_variant_tag :: GuVariant -> IO CInt
|
||||
|
||||
@@ -209,6 +225,8 @@ data PgfCncTree
|
||||
data PgfLinFuncs
|
||||
data PgfGraphvizOptions
|
||||
type PgfBindType = (#type PgfBindType)
|
||||
data PgfAbsFun
|
||||
data PgfAbsCat
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_read"
|
||||
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
|
||||
|
||||
@@ -10,7 +10,7 @@ module PGF2.Internal(-- * Access the internal structures
|
||||
|
||||
-- * Building new PGFs in memory
|
||||
build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo,
|
||||
newAbstr, newPGF,
|
||||
AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
|
||||
|
||||
-- * Write an in-memory PGF to a file
|
||||
writePGF
|
||||
@@ -26,8 +26,10 @@ import System.IO.Unsafe(unsafePerformIO)
|
||||
import Foreign
|
||||
import Foreign.C
|
||||
import Data.IORef
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe(fromMaybe)
|
||||
import Data.List(sortBy)
|
||||
import Control.Exception(Exception,throwIO)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Token = String
|
||||
data Symbol
|
||||
@@ -61,32 +63,31 @@ data Literal =
|
||||
-- Access the internal structures
|
||||
-----------------------------------------------------------------------
|
||||
|
||||
globalFlags :: PGF -> Map.Map String Literal
|
||||
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 -> Map.Map String Literal
|
||||
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 -> Map.Map String Literal
|
||||
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 (Map.Map String Literal)
|
||||
peekFlags :: Ptr GuSeq -> IO [(String,Literal)]
|
||||
peekFlags c_flags = do
|
||||
c_len <- (#peek GuSeq, len) c_flags
|
||||
list <- peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data))
|
||||
return (Map.fromAscList list)
|
||||
peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data))
|
||||
where
|
||||
peekFlags 0 ptr = return []
|
||||
peekFlags c_len ptr = do
|
||||
@@ -114,7 +115,7 @@ concrTotalCats c = unsafePerformIO $ do
|
||||
touchConcr c
|
||||
return (fromIntegral (c_total_cats :: CInt))
|
||||
|
||||
concrCategories :: Concr -> [(CId,FId,FId,[String])]
|
||||
concrCategories :: Concr -> [(Cat,FId,FId,[String])]
|
||||
concrCategories c =
|
||||
unsafePerformIO $
|
||||
withGuPool $ \tmpPl ->
|
||||
@@ -348,7 +349,7 @@ eMeta id =
|
||||
alloca $ \pptr -> do
|
||||
ptr <- gu_alloc_variant (#const PGF_EXPR_META)
|
||||
(fromIntegral (#size PgfExprMeta))
|
||||
(#const gu_flex_alignof(PgfExprMeta))
|
||||
(#const gu_alignof(PgfExprMeta))
|
||||
pptr pool
|
||||
(#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt)
|
||||
e <- peek pptr
|
||||
@@ -452,28 +453,51 @@ newHypos hypos pool = do
|
||||
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
|
||||
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
|
||||
|
||||
data AbstrInfo = Abstr (Ptr GuSeq) (Ptr GuSeq) (Ptr GuSeq) Touch
|
||||
|
||||
newAbstr :: (?builder :: Builder s) => Map.Map String Literal ->
|
||||
Map.Map Cat ([B s Hypo],Float) ->
|
||||
Map.Map Fun (B s Type,Int,Float) ->
|
||||
data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) 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 <- newMap (#size PgfAbsCat) pokeAbsCat cats pool
|
||||
c_funs <- newMap (#size PgfAbsFun) pokeAbsFun funs pool
|
||||
return (Abstr c_aflags c_cats c_funs touch)
|
||||
(c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
|
||||
(c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
|
||||
c_abs_lin_fun <- newAbsLinFun
|
||||
return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun touch)
|
||||
where
|
||||
(Builder pool touch) = ?builder
|
||||
|
||||
pokeAbsCat ptr name (hypos,prob) = do
|
||||
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)
|
||||
|
||||
pokeAbsFun ptr name (B (Type c_ty _),arity,prob) = do
|
||||
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))
|
||||
@@ -485,42 +509,159 @@ newAbstr aflags cats funs = unsafePerformIO $ do
|
||||
(#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)
|
||||
|
||||
data ConcrInfo
|
||||
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
|
||||
|
||||
newPGF :: (?builder :: Builder s) => Map.Map String Literal ->
|
||||
|
||||
data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap)
|
||||
|
||||
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
|
||||
ConcrInfo
|
||||
newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats = 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
|
||||
mapM_ (addProductions c_ccats funs_ptr) 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)
|
||||
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*) (pokeFunId 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*) (pokeFunId funs_ptr) funids pool
|
||||
(#poke PgfCCat, linrefs) c_ccat c_funs
|
||||
|
||||
addProductions c_ccats funs_ptr (fid,prods) = do
|
||||
c_ccat <- getCCat c_ccats fid pool
|
||||
c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral (length prods)) pool
|
||||
(#poke PgfCCat, prods) c_ccat c_prods
|
||||
|
||||
pokeFunId 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 ->
|
||||
Map.Map ConcName ConcrInfo ->
|
||||
[(ConcName,ConcrInfo)] ->
|
||||
B s PGF
|
||||
newPGF gflags absname (Abstr c_aflags c_cats c_funs _) concrs =
|
||||
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
|
||||
c_concrs <- newMap (#size PgfConcr) pokeConcr concrs 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.cats) ptr c_cats
|
||||
(#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 ptr name concr = do
|
||||
undefined
|
||||
pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats) = do
|
||||
c_name <- newUtf8CString name 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, cncfuns) ptr c_cncfuns
|
||||
(#poke PgfConcr, sequences) ptr c_seqs
|
||||
(#poke PgfConcr, cnccats) ptr c_cnccats
|
||||
(#poke PgfConcr, pool) ptr nullPtr
|
||||
|
||||
newFlags :: Map.Map String Literal -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
newFlags flags pool = newMap (#size PgfFlag) pokeFlag flags 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
|
||||
pokeFlag c_flag (name,value) = do
|
||||
c_name <- newUtf8CString name pool
|
||||
c_value <- newLiteral value pool
|
||||
(#poke PgfFlag, name) c_flag c_name
|
||||
@@ -539,7 +680,7 @@ newLiteral (LInt val) pool =
|
||||
alloca $ \pptr -> do
|
||||
ptr <- gu_alloc_variant (#const PGF_LITERAL_INT)
|
||||
(fromIntegral (#size PgfLiteralInt))
|
||||
(#const gu_flex_alignof(PgfLiteralInt))
|
||||
(#const gu_alignof(PgfLiteralInt))
|
||||
pptr pool
|
||||
(#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt)
|
||||
peek pptr
|
||||
@@ -547,25 +688,178 @@ newLiteral (LFlt val) pool =
|
||||
alloca $ \pptr -> do
|
||||
ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT)
|
||||
(fromIntegral (#size PgfLiteralFlt))
|
||||
(#const gu_flex_alignof(PgfLiteralFlt))
|
||||
(#const gu_alignof(PgfLiteralFlt))
|
||||
pptr pool
|
||||
(#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble)
|
||||
peek pptr
|
||||
|
||||
newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
|
||||
newSymbol pool = undefined
|
||||
|
||||
newMap :: CSizeT -> (Ptr a -> k -> v -> IO ()) -> Map.Map k v -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
newMap elem_size pokeElem m pool = do
|
||||
c_m <- gu_make_seq elem_size (fromIntegral (Map.size m)) pool
|
||||
pokeElems (c_m `plusPtr` (#offset GuSeq, data)) (Map.toAscList m)
|
||||
return c_m
|
||||
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
|
||||
pokeElems ptr [] = return ()
|
||||
pokeElems ptr ((key,value):xs) = do
|
||||
pokeElem ptr key value
|
||||
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
|
||||
|
||||
newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
newSequence elem_size pokeElem values pool = do
|
||||
c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool
|
||||
pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values
|
||||
return c_seq
|
||||
where
|
||||
pokeElems ptr [] = return ()
|
||||
pokeElems ptr (x:xs) = do
|
||||
pokeElem ptr x
|
||||
pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs
|
||||
|
||||
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
|
||||
@@ -585,3 +879,7 @@ writePGF fpath p = do
|
||||
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)
|
||||
|
||||
Reference in New Issue
Block a user