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

a light API in the Haskell binding for accessing the internal data structures

Browse Source
This commit is contained in:
Krasimir Angelov
2017-09-07 21:31:33 +02:00
parent 60bd12a952
commit 4f680b728b
3 changed files with 234 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
src/runtime/haskell-bind/PGF2/FFI.hs
View File

@@ -28,10 +28,12 @@ data GuKind
data GuType
data GuString
data GuStringBuf
data GuMap
data GuMapItor
data GuOut
data GuSeq
data GuPool
type GuVariant = Ptr ()
foreign import ccall fopen :: CString -> CString -> IO (Ptr ())
@@ -96,6 +98,19 @@ foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
foreign import ccall unsafe "gu/seq.h gu_make_seq"
gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq)
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/variant.h gu_variant_tag"
gu_variant_tag :: GuVariant -> IO CInt
foreign import ccall unsafe "gu/variant.h gu_variant_data"
gu_variant_data :: GuVariant -> IO (Ptr a)
withGuPool :: (Ptr GuPool -> IO a) -> IO a
withGuPool f = bracket gu_new_pool gu_pool_free f

217
src/runtime/haskell-bind/PGF2/Internal.hsc Normal file
View File

@@ -0,0 +1,217 @@
module PGF2.Internal(FId,isPredefFId,
FunId,Token,Production(..),PArg(..),Symbol(..),
concrTotalCats, concrCategories, concrProductions,
concrTotalFuns, concrFunction,
concrTotalSeqs, concrSequence) where
#include <pgf/data.h>
import PGF2
import PGF2.FFI
import System.IO.Unsafe(unsafePerformIO)
import Foreign
import Foreign.C
import Data.IORef
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
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 -> [(CId,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::CInt))*(#size PgfCCat*))) >>= peekFId
c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat
arr <- peekArray (fromIntegral (c_n_lins :: CInt)) (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 :: CInt))
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 :: CInt)) (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 :: CInt))
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 :: CInt) (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)
peekSequence peekElem size ptr = do
c_len <- (#peek GuSeq, len) ptr
peekElems (c_len :: CInt) (ptr `plusPtr` (#offset GuSeq, data))
where
peekElems 0 ptr = return []
peekElems len ptr = do
e <- peekElem ptr
es <- peekElems (len-1) (ptr `plusPtr` size)
return (e:es)
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])

4
src/runtime/haskell-bind/pgf2.cabal
View File

@@ -14,11 +14,11 @@ extra-source-files: README
cabal-version: >=1.10
library
exposed-modules: PGF2, SG,
exposed-modules: PGF2, PGF2.Internal, SG,
-- backwards compatibility API:
PGF, PGF.Internal
other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
build-depends: base >=4.3, bytestring >=0.9,
build-depends: base >=4.3,
containers, pretty
-- hs-source-dirs:
default-language: Haskell2010