From 71e6562eaa0efe417ff80c723aa8d582ba716d53 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Fri, 8 Sep 2017 15:15:23 +0200 Subject: [PATCH] an initial sketch for PGF building API in the Haskell binding --- src/runtime/haskell-bind/PGF2/Expr.hsc | 2 +- src/runtime/haskell-bind/PGF2/FFI.hs | 68 ++++-- src/runtime/haskell-bind/PGF2/Internal.hsc | 261 ++++++++++++++++++++- 3 files changed, 303 insertions(+), 28 deletions(-) diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index a03a24be3..90f702462 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -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) diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 8ca2d1c98..9d73ea9c3 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -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 diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc index 9f5a7f960..bd64c358e 100644 --- a/src/runtime/haskell-bind/PGF2/Internal.hsc +++ b/src/runtime/haskell-bind/PGF2/Internal.hsc @@ -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 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