an initial sketch for PGF building API in the Haskell binding

2017-09-08 15:15:23 +02:00
parent 16172be940
commit 71e6562eaa
3 changed files with 303 additions and 28 deletions
--- 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)
--- 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

--- 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 <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