summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/runtime/haskell-bind/PGF2/Expr.hsc2
-rw-r--r--src/runtime/haskell-bind/PGF2/FFI.hs68
-rw-r--r--src/runtime/haskell-bind/PGF2/Internal.hsc261
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 <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,7 +44,16 @@ 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
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:15:54 +0000