msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

handle productions in the internal creation API

Browse Source
This commit is contained in:
Krasimir Angelov
2017-09-25 13:23:53 +02:00
parent d103fe6755
commit d79ac56870
2 changed files with 110 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
src/runtime/haskell-bind/PGF2/FFI.hsc
View File

@@ -38,6 +38,7 @@ data GuMap
data GuMapItor
data GuHasher
data GuSeq
data GuBuf
data GuPool
type GuVariant = Ptr ()
type GuHash = (#type GuHash)
@@ -112,6 +113,9 @@ 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/seq.h gu_make_buf"
gu_make_buf :: CSizeT -> Ptr GuPool -> IO (Ptr GuBuf)
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)
@@ -127,6 +131,9 @@ foreign import ccall "gu/map.h gu_map_iter"
foreign import ccall unsafe "gu/hash.h &gu_int_hasher"
gu_int_hasher :: Ptr GuHasher
foreign import ccall unsafe "gu/hash.h &gu_addr_hasher"
gu_addr_hasher :: Ptr GuHasher
foreign import ccall unsafe "gu/hash.h &gu_string_hasher"
gu_string_hasher :: Ptr GuHasher
@@ -227,6 +234,9 @@ data PgfGraphvizOptions
type PgfBindType = (#type PgfBindType)
data PgfAbsFun
data PgfAbsCat
data PgfCCat
data PgfCncFun
data PgfProductionApply
foreign import ccall "pgf/pgf.h pgf_read"
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
@@ -471,3 +481,12 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment"
pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/data.h pgf_parser_index"
pgf_parser_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO ()
foreign import ccall "pgf/data.h pgf_lzr_index"
pgf_lzr_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO ()
foreign import ccall "pgf/data.h pgf_production_is_lexical"
pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool)

114
src/runtime/haskell-bind/PGF2/Internal.hsc
View File

@@ -29,6 +29,7 @@ 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
@@ -454,7 +455,7 @@ newHypos hypos pool = do
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) Touch
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)] ->
@@ -465,7 +466,8 @@ newAbstr aflags cats funs = unsafePerformIO $ do
(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)
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
@@ -531,7 +533,7 @@ newAbstr aflags cats funs = unsafePerformIO $ do
return ptr
data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap)
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
@@ -542,8 +544,9 @@ newConcr :: (?builder :: Builder s) => AbstrInfo ->
[(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 _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats = unsafePerformIO $ do
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)
@@ -558,9 +561,9 @@ newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun _) cflags printnames li
pool
mapM_ (addLindefs c_ccats funs_ptr) lindefs
mapM_ (addLinrefs c_ccats funs_ptr) linrefs
mapM_ (addProductions c_ccats funs_ptr) prods
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)
return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats))
where
(Builder pool touch) = ?builder
@@ -575,20 +578,34 @@ newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun _) cflags printnames li
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
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*) (pokeFunId funs_ptr) funids pool
c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId 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
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
pokeFunId funs_ptr ptr funid = do
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
@@ -622,7 +639,7 @@ newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
AbstrInfo ->
[(ConcName,ConcrInfo)] ->
B s PGF
newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _) 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)
@@ -645,17 +662,29 @@ newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _) con
where
(Builder pool touch) = ?builder
pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats) = do
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
(#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
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)
@@ -667,6 +696,7 @@ newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) poo
(#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
@@ -693,6 +723,44 @@ newLiteral (LFlt val) 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