mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
an initial sketch for PGF building API in the Haskell binding
This commit is contained in:
Krasimir Angelov
@@ -51,7 +51,7 @@ mkAbs bind_type var (Expr body bodyTouch) =
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl))
|
||||
where
|
||||
cbind_type =
|
||||
cbind_type =
|
||||
case bind_type of
|
||||
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
|
||||
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
|
||||
{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-}
|
||||
|
||||
module PGF2.FFI where
|
||||
|
||||
@@ -9,7 +9,7 @@ import Foreign.ForeignPtr
|
||||
import Control.Exception
|
||||
import GHC.Ptr
|
||||
import Data.Int(Int32)
|
||||
import Data.Word(Word)
|
||||
import Data.Word(Word,Word8)
|
||||
|
||||
type Touch = IO ()
|
||||
|
||||
@@ -35,30 +35,33 @@ data GuSeq
|
||||
data GuPool
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
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 ()
|
||||
|
||||
foreign import ccall "gu/mem.h &gu_pool_free"
|
||||
foreign import ccall unsafe "gu/mem.h &gu_pool_free"
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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_type_GuErrno = Ptr "GuErrno"# :: CString
|
||||
@@ -71,22 +74,22 @@ gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: 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)
|
||||
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
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 ()
|
||||
|
||||
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
|
||||
|
||||
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"
|
||||
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 f = bracket gu_new_pool gu_pool_free f
|
||||
@@ -145,15 +151,10 @@ peekUtf8CStringLen ptr len =
|
||||
cs <- decode pptr end
|
||||
return (((toEnum . fromEnum) x) : cs)
|
||||
|
||||
newUtf8CString :: String -> Ptr GuPool -> IO CString
|
||||
newUtf8CString s pool = do
|
||||
-- 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))
|
||||
pokeUtf8CString :: String -> CString -> IO ()
|
||||
pokeUtf8CString s ptr =
|
||||
alloca $ \pptr ->
|
||||
poke pptr ptr >> encode s pptr
|
||||
return ptr
|
||||
where
|
||||
encode [] pptr = do
|
||||
gu_utf8_encode 0 pptr
|
||||
@@ -161,6 +162,25 @@ newUtf8CString s pool = do
|
||||
gu_utf8_encode ((toEnum . fromEnum) c) 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
|
||||
|
||||
|
||||
@@ -1,17 +1,27 @@
|
||||
module PGF2.Internal(FId,isPredefFId,
|
||||
FunId,Token,Production(..),PArg(..),Symbol(..),
|
||||
{-# LANGUAGE ImplicitParams, RankNTypes #-}
|
||||
|
||||
module PGF2.Internal(-- * Access the internal structures
|
||||
FId,isPredefFId,
|
||||
FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..),
|
||||
concrTotalCats, concrCategories, concrProductions,
|
||||
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>
|
||||
|
||||
import PGF2
|
||||
import PGF2.FFI
|
||||
import PGF2.Expr
|
||||
import PGF2.Type
|
||||
import System.IO.Unsafe(unsafePerformIO)
|
||||
import Foreign
|
||||
import Foreign.C
|
||||
import Data.IORef
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Token = String
|
||||
data Symbol
|
||||
@@ -34,8 +44,17 @@ data Production
|
||||
data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
|
||||
type FunId = 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 c = unsafePerformIO $ do
|
||||
c_total_cats <- (#peek PgfConcr, total_cats) (concr c)
|
||||
@@ -215,3 +234,239 @@ fidStart = (-5)
|
||||
|
||||
isPredefFId :: FId -> Bool
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user