From d574bb21644bd92219a96377b4a8c9c0ae92d456 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Thu, 14 Sep 2017 15:23:13 +0200 Subject: an almost complete API for building new PGF files in the Haskell binding --- src/runtime/haskell-bind/PGF2/FFI.hsc | 20 +- src/runtime/haskell-bind/PGF2/Internal.hsc | 386 +++++++++++++++++++++++++---- 2 files changed, 361 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index 9de864fcc..e6846b66a 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -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) diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc index d24b94bc4..b74a01001 100644 --- a/src/runtime/haskell-bind/PGF2/Internal.hsc +++ b/src/runtime/haskell-bind/PGF2/Internal.hsc @@ -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) + + 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) + +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 -data ConcrInfo - -newPGF :: (?builder :: Builder s) => Map.Map String Literal -> + 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 - -newFlags :: Map.Map String Literal -> Ptr GuPool -> IO (Ptr GuSeq) -newFlags flags pool = newMap (#size PgfFlag) pokeFlag flags pool + 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 :: [(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 +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 -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 +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 - pokeElems ptr [] = return () - pokeElems ptr ((key,value):xs) = do - pokeElem ptr key value + 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) -- cgit v1.2.3