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

an API to access the grammar's flags

Browse Source
This commit is contained in:
Krasimir Angelov
2017-09-11 08:50:29 +02:00
parent 09f5c95d82
commit 6712969503
1 changed files with 48 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -3,6 +3,7 @@
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,
@@ -55,6 +56,53 @@ data Literal =
-- Access the internal structures
-----------------------------------------------------------------------
globalFlags :: PGF -> Map.Map 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 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 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 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)
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)