GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

an initial sketch for PGF building API in the Haskell binding

Browse Source
This commit is contained in:
Krasimir Angelov
2017-09-08 15:15:23 +02:00
parent 16172be940
commit 71e6562eaa
3 changed files with 303 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/runtime/haskell-bind/PGF2/Expr.hsc
View File

@@ -51,7 +51,7 @@ mkAbs bind_type var (Expr body bodyTouch) =
exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl)) return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl))
where where
cbind_type = cbind_type =
case bind_type of case bind_type of
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)

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

@@ -1,4 +1,4 @@
{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} {-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-}
module PGF2.FFI where module PGF2.FFI where
@@ -9,7 +9,7 @@ import Foreign.ForeignPtr
import Control.Exception import Control.Exception
import GHC.Ptr import GHC.Ptr
import Data.Int(Int32) import Data.Int(Int32)
import Data.Word(Word) import Data.Word(Word,Word8)
type Touch = IO () type Touch = IO ()
@@ -35,30 +35,33 @@ data GuSeq
data GuPool data GuPool
type GuVariant = Ptr () type GuVariant = Ptr ()
foreign import ccall fopen :: CString -> CString -> IO (Ptr ()) foreign import ccall unsafe fopen :: CString -> CString -> IO (Ptr ())
foreign import ccall "gu/mem.h gu_new_pool" foreign import ccall unsafe "gu/mem.h gu_new_pool"
gu_new_pool :: IO (Ptr GuPool) gu_new_pool :: IO (Ptr GuPool)
foreign import ccall "gu/mem.h gu_malloc" foreign import ccall unsafe "gu/mem.h gu_malloc"
gu_malloc :: Ptr GuPool -> CInt -> IO (Ptr a) gu_malloc :: Ptr GuPool -> CInt -> IO (Ptr a)
foreign import ccall "gu/mem.h gu_pool_free" foreign import ccall unsafe "gu/mem.h gu_malloc_aligned"
gu_malloc_aligned :: Ptr GuPool -> CInt -> CInt -> IO (Ptr a)
foreign import ccall unsafe "gu/mem.h gu_pool_free"
gu_pool_free :: Ptr GuPool -> IO () gu_pool_free :: Ptr GuPool -> IO ()
foreign import ccall "gu/mem.h &gu_pool_free" foreign import ccall unsafe "gu/mem.h &gu_pool_free"
gu_pool_finalizer :: FinalizerPtr GuPool gu_pool_finalizer :: FinalizerPtr GuPool
foreign import ccall "gu/exn.h gu_new_exn" foreign import ccall unsafe "gu/exn.h gu_new_exn"
gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn) gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn)
foreign import ccall "gu/exn.h gu_exn_is_raised" foreign import ccall unsafe "gu/exn.h gu_exn_is_raised"
gu_exn_is_raised :: Ptr GuExn -> IO Bool gu_exn_is_raised :: Ptr GuExn -> IO Bool
foreign import ccall "gu/exn.h gu_exn_caught_" foreign import ccall unsafe "gu/exn.h gu_exn_caught_"
gu_exn_caught :: Ptr GuExn -> CString -> IO Bool gu_exn_caught :: Ptr GuExn -> CString -> IO Bool
foreign import ccall "gu/exn.h gu_exn_raise_" foreign import ccall unsafe "gu/exn.h gu_exn_raise_"
gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ()) gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ())
gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString
@@ -71,22 +74,22 @@ gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString
gu_exn_type_PgfTypeError = Ptr "PgfTypeError"# :: CString gu_exn_type_PgfTypeError = Ptr "PgfTypeError"# :: CString
foreign import ccall "gu/string.h gu_string_in" foreign import ccall unsafe "gu/string.h gu_string_in"
gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn)
foreign import ccall "gu/string.h gu_new_string_buf" foreign import ccall unsafe "gu/string.h gu_new_string_buf"
gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf) gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf)
foreign import ccall "gu/string.h gu_string_buf_out" foreign import ccall unsafe "gu/string.h gu_string_buf_out"
gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut) gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut)
foreign import ccall "gu/file.h gu_file_in" foreign import ccall unsafe "gu/file.h gu_file_in"
gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn) gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn)
foreign import ccall "gu/enum.h gu_enum_next" foreign import ccall unsafe "gu/enum.h gu_enum_next"
gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO () gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
foreign import ccall "gu/string.h gu_string_buf_freeze" foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
foreign import ccall unsafe "gu/utf8.h gu_utf8_decode" foreign import ccall unsafe "gu/utf8.h gu_utf8_decode"
@@ -110,6 +113,9 @@ foreign import ccall unsafe "gu/variant.h gu_variant_tag"
foreign import ccall unsafe "gu/variant.h gu_variant_data" foreign import ccall unsafe "gu/variant.h gu_variant_data"
gu_variant_data :: GuVariant -> IO (Ptr a) gu_variant_data :: GuVariant -> IO (Ptr a)
foreign import ccall unsafe "gu/variant.h gu_alloc_variant"
gu_alloc_variant :: Word8 -> CInt -> CInt -> Ptr GuVariant -> Ptr GuPool -> IO (Ptr a)
withGuPool :: (Ptr GuPool -> IO a) -> IO a withGuPool :: (Ptr GuPool -> IO a) -> IO a
withGuPool f = bracket gu_new_pool gu_pool_free f withGuPool f = bracket gu_new_pool gu_pool_free f
@@ -145,15 +151,10 @@ peekUtf8CStringLen ptr len =
cs <- decode pptr end cs <- decode pptr end
return (((toEnum . fromEnum) x) : cs) return (((toEnum . fromEnum) x) : cs)
newUtf8CString :: String -> Ptr GuPool -> IO CString pokeUtf8CString :: String -> CString -> IO ()
newUtf8CString s pool = do pokeUtf8CString s ptr =
-- An UTF8 character takes up to 6 bytes. We allocate enough
-- memory for the worst case. This is wasteful but those
-- strings are usually allocated only temporary.
ptr <- gu_malloc pool (fromIntegral (length s * 6+1))
alloca $ \pptr -> alloca $ \pptr ->
poke pptr ptr >> encode s pptr poke pptr ptr >> encode s pptr
return ptr
where where
encode [] pptr = do encode [] pptr = do
gu_utf8_encode 0 pptr gu_utf8_encode 0 pptr
@@ -161,6 +162,25 @@ newUtf8CString s pool = do
gu_utf8_encode ((toEnum . fromEnum) c) pptr gu_utf8_encode ((toEnum . fromEnum) c) pptr
encode cs pptr encode cs pptr
newUtf8CString :: String -> Ptr GuPool -> IO CString
newUtf8CString s pool = do
ptr <- gu_malloc pool (fromIntegral (utf8Length s))
pokeUtf8CString s ptr
return ptr
utf8Length s = count 0 s
where
count !c [] = c+1
count !c (x:xs)
| ucs < 0x80 = count (c+1) xs
| ucs < 0x800 = count (c+2) xs
| ucs < 0x10000 = count (c+3) xs
| ucs < 0x200000 = count (c+4) xs
| ucs < 0x4000000 = count (c+5) xs
| otherwise = count (c+6) xs
where
ucs = fromEnum x
------------------------------------------------------------------ ------------------------------------------------------------------
-- libpgf API -- libpgf API

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

@@ -1,17 +1,27 @@
module PGF2.Internal(FId,isPredefFId, {-# LANGUAGE ImplicitParams, RankNTypes #-}
FunId,Token,Production(..),PArg(..),Symbol(..),
module PGF2.Internal(-- * Access the internal structures
FId,isPredefFId,
FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..),
concrTotalCats, concrCategories, concrProductions, concrTotalCats, concrCategories, concrProductions,
concrTotalFuns, concrFunction, concrTotalFuns, concrFunction,
concrTotalSeqs, concrSequence) where concrTotalSeqs, concrSequence,
-- * Building new PGFs in memory
withBuilder, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp
) where
#include <pgf/data.h> #include <pgf/data.h>
import PGF2 import PGF2
import PGF2.FFI import PGF2.FFI
import PGF2.Expr
import PGF2.Type
import System.IO.Unsafe(unsafePerformIO) import System.IO.Unsafe(unsafePerformIO)
import Foreign import Foreign
import Foreign.C import Foreign.C
import Data.IORef import Data.IORef
import qualified Data.Map as Map
type Token = String type Token = String
data Symbol data Symbol
@@ -34,8 +44,17 @@ data Production
data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show) data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
type FunId = Int type FunId = Int
type SeqId = Int type SeqId = Int
data Literal =
LStr String -- ^ a string constant
| LInt Int -- ^ an integer constant
| LFlt Double -- ^ a floating point constant
deriving (Eq,Ord,Show)
-----------------------------------------------------------------------
-- Access the internal structures
-----------------------------------------------------------------------
concrTotalCats :: Concr -> FId concrTotalCats :: Concr -> FId
concrTotalCats c = unsafePerformIO $ do concrTotalCats c = unsafePerformIO $ do
c_total_cats <- (#peek PgfConcr, total_cats) (concr c) c_total_cats <- (#peek PgfConcr, total_cats) (concr c)
@@ -215,3 +234,239 @@ fidStart = (-5)
isPredefFId :: FId -> Bool isPredefFId :: FId -> Bool
isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar]) isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])
-----------------------------------------------------------------------
-- Building new PGFs in memory
-----------------------------------------------------------------------
data Builder s = Builder (Ptr GuPool) Touch
newtype B s a = B a
withBuilder :: (forall s . (?builder :: Builder s) => B s a) -> a
withBuilder f =
unsafePerformIO $ do
pool <- gu_new_pool
poolFPtr <- newForeignPtr gu_pool_finalizer pool
let ?builder = Builder pool (touchForeignPtr poolFPtr)
let B res = f
return res
eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr
eAbs bind_type var (B (Expr body _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_ABS)
(#size PgfExprAbs)
(#const gu_alignof(PgfExprAbs))
pptr pool
cvar <- newUtf8CString var pool
(#poke PgfExprAbs, bind_type) ptr (cbind_type :: CInt)
(#poke PgfExprAbs, id) ptr cvar
(#poke PgfExprAbs, body) ptr body
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
cbind_type =
case bind_type of
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr
eApp (B (Expr fun _)) (B (Expr arg _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_APP)
(#size PgfExprApp)
(#const gu_alignof(PgfExprApp))
pptr pool
(#poke PgfExprApp, fun) ptr fun
(#poke PgfExprApp, arg) ptr arg
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eMeta :: (?builder :: Builder s) => Int -> B s Expr
eMeta id =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_META)
(fromIntegral (#size PgfExprMeta))
(#const gu_flex_alignof(PgfExprMeta))
pptr pool
(#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt)
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eFun :: (?builder :: Builder s) => Fun -> B s Expr
eFun fun =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_FUN)
(fromIntegral ((#size PgfExprFun)+utf8Length fun))
(#const gu_flex_alignof(PgfExprFun))
pptr pool
pokeUtf8CString fun (ptr `plusPtr` (#offset PgfExprFun, fun))
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eVar :: (?builder :: Builder s) => Int -> B s Expr
eVar var =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_VAR)
(#size PgfExprVar)
(#const gu_alignof(PgfExprVar))
pptr pool
(#poke PgfExprVar, var) ptr (fromIntegral var :: CInt)
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr
eTyped (B (Expr e _)) (B (Type ty _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_TYPED)
(#size PgfExprTyped)
(#const gu_alignof(PgfExprTyped))
pptr pool
(#poke PgfExprTyped, expr) ptr e
(#poke PgfExprTyped, type) ptr ty
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr
eImplArg (B (Expr e _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_EXPR_IMPL_ARG)
(#size PgfExprImplArg)
(#const gu_alignof(PgfExprImplArg))
pptr pool
(#poke PgfExprImplArg, expr) ptr e
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
dTyp :: (?builder :: Builder s) => [(BindType,CId,B s Type)] -> Cat -> [B s Expr] -> B s Type
dTyp hypos cat es =
unsafePerformIO $ do
ptr <- gu_malloc_aligned pool
((#size PgfType)+n_exprs*(#size GuVariant))
(#const gu_flex_alignof(PgfType))
c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool
pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos
c_cat <- newUtf8CString cat pool
(#poke PgfType, hypos) ptr c_hypos
(#poke PgfType, cid) ptr c_cat
(#poke PgfType, n_exprs) ptr n_exprs
pokeArray (ptr `plusPtr` (#offset PgfType, exprs)) [e | B (Expr e _) <- es]
return (B (Type ptr touch))
where
(Builder pool touch) = ?builder
n_exprs = fromIntegral (length es) :: CInt
pokeHypos ptr [] = return ()
pokeHypos ptr ((bind_type,var,B (Type ty _)):hypos) = do
c_var <- newUtf8CString var pool
(#poke PgfHypo, bind_type) ptr (cbind_type :: CInt)
(#poke PgfHypo, cid) ptr c_var
(#poke PgfHypo, type) ptr ty
pokeHypos (ptr `plusPtr` (#size PgfHypo)) hypos
where
cbind_type =
case bind_type of
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
newPGF :: (?builder :: Builder s) => Map.Map String Literal ->
AbsName ->
Map.Map String Literal ->
Map.Map Cat ([Hypo],Float) ->
Map.Map Fun (Type,Float) ->
Map.Map ConcName () ->
B s PGF
newPGF gflags absname aflags cats funs 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_aflags <- newFlags aflags pool
c_concrs <- gu_make_seq (#size PgfConcr) (fromIntegral (Map.size concrs)) pool
pokeConcrs (c_concrs `plusPtr` (#offset GuSeq, data)) (Map.toList concrs)
(#poke PgfPGF, major_version) ptr (2 :: Word16)
(#poke PgfPGF, minor_version) ptr (0 :: Word16)
(#poke PgfPGF, gflags) ptr c_gflags
(#poke PgfPGF, abstract.name) ptr c_absname
(#poke PgfPGF, abstract.aflags) ptr c_aflags
(#poke PgfPGF, concretes) ptr c_concrs
(#poke PgfPGF, pool) ptr pool
return (B (PGF ptr touch))
where
(Builder pool touch) = ?builder
pokeConcrs ptr [] = return ()
pokeConcrs ptr ((name,concr):concrs) = do
initConcr ptr name concr pool
pokeConcrs (ptr `plusPtr` (#size PgfConcr)) concrs
newFlags :: Map.Map String Literal -> Ptr GuPool -> IO (Ptr GuSeq)
newFlags flags pool = do
c_flags <- gu_make_seq (#size PgfFlag) (fromIntegral (Map.size flags)) pool
pokeFlags (c_flags `plusPtr` (#offset GuSeq, data)) (Map.toList flags)
return c_flags
where
pokeFlags c_flag [] = return ()
pokeFlags c_flag ((name,value):flags) = do
c_name <- newUtf8CString name pool
c_value <- newLiteral value pool
(#poke PgfFlag, name) c_flag c_name
(#poke PgfFlag, value) c_flag c_value
pokeFlags (c_flag `plusPtr` (#size PgfFlag)) flags
newLiteral :: Literal -> Ptr GuPool -> IO GuVariant
newLiteral (LStr val) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_LITERAL_STR)
(fromIntegral ((#size PgfLiteralStr)+utf8Length val))
(#const gu_flex_alignof(PgfLiteralStr))
pptr pool
pokeUtf8CString val (ptr `plusPtr` (#offset PgfLiteralStr, val))
peek pptr
newLiteral (LInt val) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_LITERAL_INT)
(fromIntegral (#size PgfLiteralInt))
(#const gu_flex_alignof(PgfLiteralInt))
pptr pool
(#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt)
peek pptr
newLiteral (LFlt val) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT)
(fromIntegral (#size PgfLiteralFlt))
(#const gu_flex_alignof(PgfLiteralFlt))
pptr pool
(#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble)
peek pptr
initConcr :: Ptr PgfConcr -> ConcName -> () -> Ptr GuPool -> IO ()
initConcr ptr name c pool = do
return ()
newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
newSymbol pool = undefined