diff options
Diffstat (limited to 'src/runtime/haskell-bind/PGF2')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/Expr.hsc | 47 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hsc (renamed from src/runtime/haskell-bind/PGF2/FFI.hs) | 251 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/Internal.hsc | 932 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/Type.hsc | 60 |
4 files changed, 1212 insertions, 78 deletions
diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index a03a24be3..096d15bfa 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -5,6 +5,7 @@ module PGF2.Expr where import System.IO.Unsafe(unsafePerformIO) import Foreign hiding (unsafePerformIO) import Foreign.C +import Data.IORef import PGF2.FFI -- | An data type that represents @@ -51,7 +52,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) @@ -195,7 +196,7 @@ readExpr str = do c_str <- newUtf8CString str tmpPl guin <- gu_string_in c_str tmpPl exn <- gu_new_exn tmpPl - c_expr <- pgf_read_expr guin exprPl exn + c_expr <- pgf_read_expr guin exprPl tmpPl exn status <- gu_exn_is_raised exn if (not status && c_expr /= nullPtr) then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl @@ -203,6 +204,48 @@ readExpr str = else do gu_pool_free exprPl return Nothing +pExpr :: ReadS Expr +pExpr str = + unsafePerformIO $ + do exprPl <- gu_new_pool + withGuPool $ \tmpPl -> + do ref <- newIORef (str,str,str) + exn <- gu_new_exn tmpPl + c_fetch_char <- wrapParserGetc (fetch_char ref) + c_parser <- pgf_new_parser nullPtr c_fetch_char exprPl tmpPl exn + c_expr <- pgf_expr_parser_expr c_parser 1 + status <- gu_exn_is_raised exn + if (not status && c_expr /= nullPtr) + then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + (str,_,_) <- readIORef ref + return [(Expr c_expr (touchForeignPtr exprFPl),str)] + else do gu_pool_free exprPl + return [] + where + fetch_char :: IORef (String,String,String) -> Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS) + fetch_char ref _ mark exn = do + (str1,str2,str3) <- readIORef ref + let str1' = if mark /= 0 + then str2 + else str1 + case str3 of + [] -> do writeIORef ref (str1',str3,[]) + gu_exn_raise exn gu_exn_type_GuEOF + return (-1) + (c:cs) -> do writeIORef ref (str1',str3,cs) + return ((fromIntegral . fromEnum) c) + +foreign import ccall "pgf/expr.h pgf_new_parser" + pgf_new_parser :: Ptr () -> (FunPtr ParserGetc) -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfExprParser) + +foreign import ccall "pgf/expr.h pgf_expr_parser_expr" + pgf_expr_parser_expr :: Ptr PgfExprParser -> (#type bool) -> IO PgfExpr + +type ParserGetc = Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS) + +foreign import ccall "wrapper" + wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc) + -- | renders an expression as a 'String'. The list -- of identifiers is the list of all free variables -- in the expression in order reverse to the order diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hsc index 3870e2fba..c33f1da50 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -1,14 +1,20 @@ -{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-} module PGF2.FFI where -import Foreign ( alloca, poke ) +#include <gu/defs.h> +#include <gu/hash.h> +#include <gu/utf8.h> +#include <pgf/pgf.h> + +import Foreign ( alloca, peek, poke, peekByteOff ) import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr import Control.Exception import GHC.Ptr -import Data.Int(Int32) +import Data.Int +import Data.Word type Touch = IO () @@ -23,77 +29,128 @@ data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch} data GuEnum data GuExn data GuIn +data GuOut data GuKind data GuType data GuString data GuStringBuf +data GuMap data GuMapItor -data GuOut +data GuHasher data GuSeq +data GuBuf data GuPool +type GuVariant = Ptr () +type GuHash = (#type GuHash) +type GuUCS = (#type GuUCS) -foreign import ccall fopen :: CString -> CString -> IO (Ptr ()) +type CSizeT = (#type size_t) +type CUInt8 = (#type uint8_t) -foreign import ccall "gu/mem.h gu_new_pool" +foreign import ccall unsafe fopen :: CString -> CString -> IO (Ptr ()) + +foreign import ccall unsafe "gu/mem.h gu_new_pool" gu_new_pool :: IO (Ptr GuPool) -foreign import ccall "gu/mem.h gu_malloc" - gu_malloc :: Ptr GuPool -> CInt -> IO (Ptr a) +foreign import ccall unsafe "gu/mem.h gu_malloc" + gu_malloc :: Ptr GuPool -> CSizeT -> IO (Ptr a) + +foreign import ccall unsafe "gu/mem.h gu_malloc_aligned" + gu_malloc_aligned :: Ptr GuPool -> CSizeT -> CSizeT -> IO (Ptr a) -foreign import ccall "gu/mem.h gu_pool_free" +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 +gu_exn_type_GuErrno = Ptr "GuErrno"## :: CString + +gu_exn_type_GuEOF = Ptr "GuEOF"## :: CString -gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString +gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString -gu_exn_type_PgfExn = Ptr "PgfExn"# :: CString +gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString -gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString +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) -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" - gu_utf8_decode :: Ptr CString -> IO Int32 + gu_utf8_decode :: Ptr CString -> IO GuUCS foreign import ccall unsafe "gu/utf8.h gu_utf8_encode" - gu_utf8_encode :: Int32 -> Ptr CString -> IO () + gu_utf8_encode :: GuUCS -> Ptr CString -> IO () foreign import ccall unsafe "gu/seq.h gu_make_seq" - gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq) + gu_make_seq :: CSizeT -> CSizeT -> Ptr GuPool -> IO (Ptr GuSeq) + +foreign import ccall unsafe "gu/seq.h gu_make_buf" + gu_make_buf :: CSizeT -> Ptr GuPool -> IO (Ptr GuBuf) + +foreign import ccall unsafe "gu/map.h gu_make_map" + gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap) + +foreign import ccall unsafe "gu/map.h gu_map_insert" + gu_map_insert :: Ptr GuMap -> Ptr a -> IO (Ptr b) + +foreign import ccall unsafe "gu/map.h gu_map_find_default" + gu_map_find_default :: Ptr GuMap -> Ptr a -> IO (Ptr b) + +foreign import ccall "gu/map.h gu_map_iter" + gu_map_iter :: Ptr GuMap -> Ptr GuMapItor -> Ptr GuExn -> IO () + +foreign import ccall unsafe "gu/hash.h &gu_int_hasher" + gu_int_hasher :: Ptr GuHasher + +foreign import ccall unsafe "gu/hash.h &gu_addr_hasher" + gu_addr_hasher :: Ptr GuHasher + +foreign import ccall unsafe "gu/hash.h &gu_string_hasher" + gu_string_hasher :: Ptr GuHasher + +foreign import ccall unsafe "gu/hash.h &gu_null_struct" + gu_null_struct :: Ptr a + +foreign import ccall unsafe "gu/variant.h gu_variant_tag" + gu_variant_tag :: GuVariant -> IO CInt + +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 :: CUInt8 -> CSizeT -> CSizeT -> Ptr GuVariant -> Ptr GuPool -> IO (Ptr a) + withGuPool :: (Ptr GuPool -> IO a) -> IO a withGuPool f = bracket gu_new_pool gu_pool_free f @@ -116,15 +173,23 @@ peekUtf8CString ptr = else do cs <- decode pptr 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)) +peekUtf8CStringLen :: CString -> CInt -> IO String +peekUtf8CStringLen ptr len = + alloca $ \pptr -> + poke pptr ptr >> decode pptr (ptr `plusPtr` fromIntegral len) + where + decode pptr end = do + ptr <- peek pptr + if ptr >= end + then return [] + else do x <- gu_utf8_decode pptr + cs <- decode pptr end + return (((toEnum . fromEnum) x) : cs) + +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 @@ -132,6 +197,46 @@ 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 + +peekSequence peekElem size ptr = do + c_len <- (#peek GuSeq, len) ptr + peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data)) + where + peekElems 0 ptr = return [] + peekElems len ptr = do + e <- peekElem ptr + es <- peekElems (len-1) (ptr `plusPtr` size) + return (e:es) + +newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq) +newSequence elem_size pokeElem values pool = do + c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool + pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values + return c_seq + where + pokeElems ptr [] = return () + pokeElems ptr (x:xs) = do + pokeElem ptr x + pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs + ------------------------------------------------------------------ -- libpgf API @@ -140,6 +245,7 @@ data PgfApplication data PgfConcr type PgfExpr = Ptr () data PgfExprProb +data PgfExprParser data PgfFullFormEntry data PgfMorphoCallback data PgfPrintContext @@ -149,10 +255,19 @@ data PgfOracleCallback data PgfCncTree data PgfLinFuncs data PgfGraphvizOptions +type PgfBindType = (#type PgfBindType) +data PgfAbsFun +data PgfAbsCat +data PgfCCat +data PgfCncFun +data PgfProductionApply foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) +foreign import ccall "pgf/pgf.h pgf_write" + pgf_write :: Ptr PgfPGF -> CString -> Ptr GuExn -> IO () + foreign import ccall "pgf/pgf.h pgf_abstract_name" pgf_abstract_name :: Ptr PgfPGF -> IO CString @@ -180,6 +295,12 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories" foreign import ccall "pgf/pgf.h pgf_start_cat" pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType +foreign import ccall "pgf/pgf.h pgf_category_context" + pgf_category_context :: Ptr PgfPGF -> CString -> IO (Ptr GuSeq) + +foreign import ccall "pgf/pgf.h pgf_category_prob" + pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t) + foreign import ccall "pgf/pgf.h pgf_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () @@ -189,6 +310,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" foreign import ccall "pgf/pgf.h pgf_function_type" pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType +foreign import ccall "pgf/expr.h pgf_function_is_constructor" + pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool) + foreign import ccall "pgf/pgf.h pgf_print_name" pgf_print_name :: Ptr PgfConcr -> CString -> IO CString @@ -205,16 +329,16 @@ foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref" pgf_lzr_wrap_linref :: Ptr PgfCncTree -> Ptr GuPool -> IO (Ptr PgfCncTree) foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple" - pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () + pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () foreign import ccall "pgf/pgf.h pgf_lzr_linearize" - pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () + pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () foreign import ccall "pgf/pgf.h pgf_lzr_get_table" - pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CInt -> Ptr (Ptr CString) -> IO () + pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CSizeT -> Ptr (Ptr CString) -> IO () type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO () -type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CInt -> CString -> IO () +type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CSizeT -> CString -> IO () type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO () type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO () @@ -239,12 +363,12 @@ foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics" foreign import ccall "pgf/pgf.h pgf_lookup_sentence" pgf_lookup_sentence :: Ptr PgfConcr -> PgfType -> CString -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) -type LiteralMatchCallback = CInt -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) +type LiteralMatchCallback = CSizeT -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback) -type LiteralPredictCallback = CInt -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) +type LiteralPredictCallback = CSizeT -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback) @@ -255,8 +379,8 @@ foreign import ccall "pgf/pgf.h pgf_new_callbacks_map" foreign import ccall hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO () -type OracleCallback = CString -> CString -> CInt -> IO Bool -type OracleLiteralCallback = CString -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) +type OracleCallback = CString -> CString -> CSizeT -> IO Bool +type OracleLiteralCallback = CString -> CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapOracleCallback :: OracleCallback -> IO (FunPtr OracleCallback) @@ -299,7 +423,7 @@ foreign import ccall "pgf/pgf.h pgf_expr_unapply" pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication) foreign import ccall "pgf/pgf.h pgf_expr_abs" - pgf_expr_abs :: CInt -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr + pgf_expr_abs :: PgfBindType -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr foreign import ccall "pgf/pgf.h pgf_expr_unabs" pgf_expr_unabs :: PgfExpr -> IO (Ptr a) @@ -328,6 +452,18 @@ foreign import ccall "pgf/expr.h pgf_expr_arity" foreign import ccall "pgf/expr.h pgf_expr_eq" pgf_expr_eq :: PgfExpr -> PgfExpr -> IO CInt +foreign import ccall "pgf/expr.h pgf_expr_hash" + pgf_expr_hash :: GuHash -> PgfExpr -> IO GuHash + +foreign import ccall "pgf/expr.h pgf_expr_size" + pgf_expr_size :: PgfExpr -> IO CInt + +foreign import ccall "pgf/expr.h pgf_expr_functions" + pgf_expr_functions :: PgfExpr -> Ptr GuPool -> IO (Ptr GuSeq) + +foreign import ccall "pgf/expr.h pgf_expr_substitute" + pgf_expr_substitute :: PgfExpr -> Ptr GuSeq -> Ptr GuPool -> IO PgfExpr + foreign import ccall "pgf/expr.h pgf_compute_tree_probability" pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat @@ -347,14 +483,14 @@ foreign import ccall "pgf/expr.h pgf_print_expr" pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_print_expr_tuple" - pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/expr.h pgf_print_category" - pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO () + pgf_print_expr_tuple :: CSizeT -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_print_type" pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO () +foreign import ccall "pgf/expr.h pgf_print_context" + pgf_print_context :: Ptr GuSeq -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () + foreign import ccall "pgf/pgf.h pgf_generate_all" pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) @@ -362,16 +498,16 @@ foreign import ccall "pgf/pgf.h pgf_print" pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_read_expr" - pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr + pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr foreign import ccall "pgf/expr.h pgf_read_expr_tuple" - pgf_read_expr_tuple :: Ptr GuIn -> CInt -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt + pgf_read_expr_tuple :: Ptr GuIn -> CSizeT -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt foreign import ccall "pgf/expr.h pgf_read_expr_matrix" - pgf_read_expr_matrix :: Ptr GuIn -> CInt -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq) + pgf_read_expr_matrix :: Ptr GuIn -> CSizeT -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq) foreign import ccall "pgf/expr.h pgf_read_type" - pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType + pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree" pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () @@ -380,4 +516,13 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree" pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment" - pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CInt -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () + pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () + +foreign import ccall "pgf/data.h pgf_parser_index" + pgf_parser_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO () + +foreign import ccall "pgf/data.h pgf_lzr_index" + pgf_lzr_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO () + +foreign import ccall "pgf/data.h pgf_production_is_lexical" + pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool) diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc new file mode 100644 index 000000000..c4aef323a --- /dev/null +++ b/src/runtime/haskell-bind/PGF2/Internal.hsc @@ -0,0 +1,932 @@ +{-# LANGUAGE ImplicitParams, RankNTypes #-} + +module PGF2.Internal(-- * Access the internal structures + FId,isPredefFId, + FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..), + globalFlags, abstrFlags, concrFlags, + concrTotalCats, concrCategories, concrProductions, + concrTotalFuns, concrFunction, + concrTotalSeqs, concrSequence, + + -- * Building new PGFs in memory + build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo, + AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF, + + -- * Write an in-memory PGF to a file + writePGF + ) 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 Data.Maybe(fromMaybe) +import Data.List(sortBy) +import Control.Exception(Exception,throwIO) +import Control.Monad(foldM) +import qualified Data.Map as Map + +type Token = String +data Symbol + = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SymKS Token + | SymKP [Symbol] [([Symbol],[String])] + | SymBIND -- the special BIND token + | SymNE -- non exist + | SymSOFT_BIND -- the special SOFT_BIND token + | SymSOFT_SPACE -- the special SOFT_SPACE token + | SymCAPIT -- the special CAPIT token + | SymALL_CAPIT -- the special ALL_CAPIT token + deriving (Eq,Ord,Show) +data Production + = PApply {-# UNPACK #-} !FunId [PArg] + | PCoerce {-# UNPACK #-} !FId + deriving (Eq,Ord,Show) +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 +----------------------------------------------------------------------- + +globalFlags :: PGF -> [(String,Literal)] +globalFlags p = unsafePerformIO $ do + c_flags <- (#peek PgfPGF, gflags) (pgf p) + flags <- peekFlags c_flags + touchPGF p + return flags + +abstrFlags :: PGF -> [(String,Literal)] +abstrFlags p = unsafePerformIO $ do + c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p) + flags <- peekFlags c_flags + touchPGF p + return flags + +concrFlags :: Concr -> [(String,Literal)] +concrFlags c = unsafePerformIO $ do + c_flags <- (#peek PgfConcr, cflags) (concr c) + flags <- peekFlags c_flags + touchConcr c + return flags + +peekFlags :: Ptr GuSeq -> IO [(String,Literal)] +peekFlags c_flags = do + c_len <- (#peek GuSeq, len) c_flags + peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data)) + where + peekFlags 0 ptr = return [] + peekFlags c_len ptr = do + name <- (#peek PgfFlag, name) ptr >>= peekUtf8CString + value <- (#peek PgfFlag, value) ptr >>= peekLiteral + flags <- peekFlags (c_len-1) (ptr `plusPtr` (#size PgfFlag)) + return ((name,value):flags) + +peekLiteral :: GuVariant -> IO Literal +peekLiteral p = do + tag <- gu_variant_tag p + ptr <- gu_variant_data p + case tag of + (#const PGF_LITERAL_STR) -> do { val <- peekUtf8CString (ptr `plusPtr` (#offset PgfLiteralStr, val)); + return (LStr val) } + (#const PGF_LITERAL_INT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralInt, val)); + return (LInt (fromIntegral (val :: CInt))) } + (#const PGF_LITERAL_FLT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralFlt, val)); + return (LFlt (realToFrac (val :: CDouble))) } + _ -> error "Unknown literal type in the grammar" + +concrTotalCats :: Concr -> FId +concrTotalCats c = unsafePerformIO $ do + c_total_cats <- (#peek PgfConcr, total_cats) (concr c) + touchConcr c + return (fromIntegral (c_total_cats :: CInt)) + +concrCategories :: Concr -> [(Cat,FId,FId,[String])] +concrCategories c = + unsafePerformIO $ + withGuPool $ \tmpPl -> + allocaBytes (#size GuMapItor) $ \itor -> do + exn <- gu_new_exn tmpPl + ref <- newIORef [] + fptr <- wrapMapItorCallback (getCategories ref) + (#poke GuMapItor, fn) itor fptr + c_cnccats <- (#peek PgfConcr, cnccats) (concr c) + gu_map_iter c_cnccats itor exn + touchConcr c + freeHaskellFunPtr fptr + cs <- readIORef ref + return (reverse cs) + where + getCategories ref itor key value exn = do + names <- readIORef ref + name <- peekUtf8CString (castPtr key) + c_cnccat <- peek (castPtr value) + c_cats <- (#peek PgfCncCat, cats) c_cnccat + c_len <- (#peek GuSeq, len) c_cats + first <- peek (c_cats `plusPtr` (#offset GuSeq, data)) >>= peekFId + last <- peek (c_cats `plusPtr` ((#offset GuSeq, data) + (fromIntegral (c_len-1::CSizeT))*(#size PgfCCat*))) >>= peekFId + c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat + arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) + labels <- mapM peekUtf8CString arr + writeIORef ref ((name,first,last,labels) : names) + +concrProductions :: Concr -> FId -> [Production] +concrProductions c fid = unsafePerformIO $ do + c_ccats <- (#peek PgfConcr, ccats) (concr c) + res <- alloca $ \pfid -> do + poke pfid (fromIntegral fid :: CInt) + gu_map_find_default c_ccats pfid >>= peek + if res == nullPtr + then do touchConcr c + return [] + else do c_prods <- (#peek PgfCCat, prods) res + if c_prods == nullPtr + then do touchConcr c + return [] + else do res <- peekSequence (deRef peekProduction) (#size GuVariant) c_prods + touchConcr c + return res + where + peekProduction p = do + tag <- gu_variant_tag p + dt <- gu_variant_data p + case tag of + (#const PGF_PRODUCTION_APPLY) -> do { c_cncfun <- (#peek PgfProductionApply, fun) dt ; + c_funid <- (#peek PgfCncFun, funid) c_cncfun ; + c_args <- (#peek PgfProductionApply, args) dt ; + pargs <- peekSequence peekPArg (#size PgfPArg) c_args ; + return (PApply (fromIntegral (c_funid :: CInt)) pargs) } + (#const PGF_PRODUCTION_COERCE)-> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ; + fid <- peekFId c_coerce ; + return (PCoerce fid) } + _ -> error "Unknown production type in the grammar" + where + peekPArg ptr = do + c_hypos <- (#peek PgfPArg, hypos) ptr + hypos <- peekSequence (deRef peekFId) (#size int) c_hypos + c_ccat <- (#peek PgfPArg, ccat) ptr + fid <- peekFId c_ccat + return (PArg hypos fid) + +peekFId c_ccat = do + c_fid <- (#peek PgfCCat, fid) c_ccat + return (fromIntegral (c_fid :: CInt)) + +concrTotalFuns :: Concr -> FunId +concrTotalFuns c = unsafePerformIO $ do + c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) + c_len <- (#peek GuSeq, len) c_cncfuns + touchConcr c + return (fromIntegral (c_len :: CSizeT)) + +concrFunction :: Concr -> FunId -> (Fun,[SeqId]) +concrFunction c funid = unsafePerformIO $ do + c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) + c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*))) + c_absfun <- (#peek PgfCncFun, absfun) c_cncfun + c_name <- (#peek PgfAbsFun, name) c_absfun + name <- peekUtf8CString c_name + c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun + arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins)) + seqs_seq <- (#peek PgfConcr, sequences) (concr c) + touchConcr c + let seqs = seqs_seq `plusPtr` (#offset GuSeq, data) + return (name, map (toSeqId seqs) arr) + where + toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence) + +concrTotalSeqs :: Concr -> SeqId +concrTotalSeqs c = unsafePerformIO $ do + seq <- (#peek PgfConcr, sequences) (concr c) + c_len <- (#peek GuSeq, len) seq + touchConcr c + return (fromIntegral (c_len :: CSizeT)) + +concrSequence :: Concr -> SeqId -> [Symbol] +concrSequence c seqid = unsafePerformIO $ do + c_sequences <- (#peek PgfConcr, sequences) (concr c) + let c_sequence = c_sequences `plusPtr` ((#offset GuSeq, data)+seqid*(#size PgfSequence)) + c_syms <- (#peek PgfSequence, syms) c_sequence + res <- peekSequence (deRef peekSymbol) (#size GuVariant) c_syms + touchConcr c + return res + where + peekSymbol p = do + tag <- gu_variant_tag p + dt <- gu_variant_data p + case tag of + (#const PGF_SYMBOL_CAT) -> peekSymbolIdx SymCat dt + (#const PGF_SYMBOL_LIT) -> peekSymbolIdx SymLit dt + (#const PGF_SYMBOL_VAR) -> peekSymbolIdx SymVar dt + (#const PGF_SYMBOL_KS) -> peekSymbolKS dt + (#const PGF_SYMBOL_KP) -> peekSymbolKP dt + (#const PGF_SYMBOL_BIND) -> return SymBIND + (#const PGF_SYMBOL_SOFT_BIND) -> return SymSOFT_BIND + (#const PGF_SYMBOL_NE) -> return SymNE + (#const PGF_SYMBOL_SOFT_SPACE) -> return SymSOFT_SPACE + (#const PGF_SYMBOL_CAPIT) -> return SymCAPIT + (#const PGF_SYMBOL_ALL_CAPIT) -> return SymALL_CAPIT + _ -> error "Unknown symbol type in the grammar" + + peekSymbolIdx constr dt = do + c_d <- (#peek PgfSymbolIdx, d) dt + c_r <- (#peek PgfSymbolIdx, r) dt + return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt))) + + peekSymbolKS dt = do + token <- peekUtf8CString (dt `plusPtr` (#offset PgfSymbolKS, token)) + return (SymKS token) + + peekSymbolKP dt = do + c_default_form <- (#peek PgfSymbolKP, default_form) dt + default_form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_default_form + c_n_forms <- (#peek PgfSymbolKP, n_forms) dt + forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` (#offset PgfSymbolKP, forms)) + return (SymKP default_form forms) + + peekForms 0 ptr = return [] + peekForms len ptr = do + c_form <- (#peek PgfAlternative, form) ptr + form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_form + c_prefixes <- (#peek PgfAlternative, prefixes) ptr + prefixes <- peekSequence (deRef peekUtf8CString) (#size GuString*) c_prefixes + forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative)) + return ((form,prefixes):forms) + +deRef peekValue ptr = peek ptr >>= peekValue + +fidString, fidInt, fidFloat, fidVar, fidStart :: FId +fidString = (-1) +fidInt = (-2) +fidFloat = (-3) +fidVar = (-4) +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 + +build :: (forall s . (?builder :: Builder s) => B s a) -> a +build 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 :: PgfBindType) + (#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_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 + +hypo :: BindType -> CId -> B s Type -> (B s Hypo) +hypo bind_type var (B ty) = B (bind_type,var,ty) + +dTyp :: (?builder :: Builder s) => [B s Hypo] -> 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 <- newHypos hypos pool + 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) :: CSizeT + +newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq) +newHypos hypos pool = do + c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool + pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos + return c_hypos + where + pokeHypos ptr [] = return () + pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do + c_var <- newUtf8CString var pool + (#poke PgfHypo, bind_type) ptr (cbind_type :: PgfBindType) + (#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) + + +data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch + +newAbstr :: (?builder :: Builder s) => [(String,Literal)] -> + [(Cat,[B s Hypo],Float)] -> + [(Fun,B s Type,Int,Float)] -> + AbstrInfo +newAbstr aflags cats funs = unsafePerformIO $ do + c_aflags <- newFlags aflags pool + (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool + (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool + c_abs_lin_fun <- newAbsLinFun + c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool + return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch) + where + (Builder pool touch) = ?builder + + newAbsCats values pool = do + c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool + abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values + return (c_seq,abscats) + where + pokeElems ptr abscats [] = return abscats + pokeElems ptr abscats (x:xs) = do + abscats <- pokeAbsCat ptr abscats x + pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs + + pokeAbsCat ptr abscats (name,hypos,prob) = do + c_name <- newUtf8CString name pool + c_hypos <- newHypos hypos pool + (#poke PgfAbsCat, name) ptr c_name + (#poke PgfAbsCat, context) ptr c_hypos + (#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat) + return (Map.insert name ptr abscats) + + newAbsFuns values pool = do + c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool + absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values + return (c_seq,absfuns) + where + pokeElems ptr absfuns [] = return absfuns + pokeElems ptr absfuns (x:xs) = do + absfuns <- pokeAbsFun ptr absfuns x + pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs + + pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do + pfun <- gu_alloc_variant (#const PGF_EXPR_FUN) + (fromIntegral ((#size PgfExprFun)+utf8Length name)) + (#const gu_flex_alignof(PgfExprFun)) + (ptr `plusPtr` (#offset PgfAbsFun, ep.expr)) pool + let c_name = (pfun `plusPtr` (#offset PgfExprFun, fun)) + pokeUtf8CString name c_name + (#poke PgfAbsFun, name) ptr c_name + (#poke PgfAbsFun, type) ptr c_ty + (#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt) + (#poke PgfAbsFun, defns) ptr nullPtr + (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat) + return (Map.insert name ptr absfuns) + + newAbsLinFun = do + ptr <- gu_malloc_aligned pool + (#size PgfAbsFun) + (#const gu_alignof(PgfAbsFun)) + c_wild <- newUtf8CString "_" pool + c_ty <- gu_malloc_aligned pool + (#size PgfType) + (#const gu_alignof(PgfType)) + (#poke PgfType, hypos) c_ty nullPtr + (#poke PgfType, cid) c_ty c_wild + (#poke PgfType, n_exprs) c_ty (0 :: CSizeT) + (#poke PgfAbsFun, name) ptr c_wild + (#poke PgfAbsFun, type) ptr c_ty + (#poke PgfAbsFun, arity) ptr (0 :: CSizeT) + (#poke PgfAbsFun, defns) ptr nullPtr + (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat) + (#poke PgfAbsFun, ep.expr) ptr nullPtr + return ptr + + +data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt + +newConcr :: (?builder :: Builder s) => AbstrInfo -> + [(String,Literal)] -> -- ^ Concrete syntax flags + [(String,String)] -> -- ^ Printnames + [(FId,[FunId])] -> -- ^ Lindefs + [(FId,[FunId])] -> -- ^ Linrefs + [(FId,[Production])] -> -- ^ Productions + [(Fun,[SeqId])] -> -- ^ Concrete functions (must be sorted by Fun) + [[Symbol]] -> -- ^ Sequences (must be sorted) + [(Cat,FId,FId,[String])] -> -- ^ Concrete categories + FId -> -- ^ The total count of the categories + ConcrInfo +newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do + c_cflags <- newFlags cflags pool + c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString + (#size GuString) (pokeString pool) + printnames pool + c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool + let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data) + c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool + let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data) + c_ccats <- gu_make_map (#size int) gu_int_hasher + (#size PgfCCat*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + mapM_ (addLindefs c_ccats funs_ptr) lindefs + mapM_ (addLinrefs c_ccats funs_ptr) linrefs + mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods + c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool + return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats)) + where + (Builder pool touch) = ?builder + + pokeCncFun seqs_ptr ptr cncfun = do + c_cncfun <- newCncFun absfuns nullPtr cncfun pool + poke ptr c_cncfun + + pokeSequence c_seq syms = do + c_syms <- newSymbols syms pool + (#poke PgfSequence, syms) c_seq c_syms + (#poke PgfSequence, idx) c_seq nullPtr + + addLindefs c_ccats funs_ptr (fid,funids) = do + c_ccat <- getCCat c_ccats fid pool + c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool + (#poke PgfCCat, lindefs) c_ccat c_funs + + addLinrefs c_ccats funs_ptr (fid,funids) = do + c_ccat <- getCCat c_ccats fid pool + c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool + (#poke PgfCCat, linrefs) c_ccat c_funs + + addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do + c_ccat <- getCCat c_ccats fid pool + let n_prods = length prods + c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral n_prods) pool + (#poke PgfCCat, prods) c_ccat c_prods + pokeProductions c_ccat (c_prods `plusPtr` (#offset GuSeq, data)) 0 (n_prods-1) mk_index prods + where + pokeProductions c_ccat ptr top bot mk_index [] = return mk_index + pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do + (is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool + let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool + pgf_lzr_index concr c_ccat c_prod is_lexical pool + mk_index concr pool + if is_lexical == 0 + then do poke (ptr `plusPtr` ((#size PgfProduction)*top)) c_prod + pokeProductions c_ccat ptr (top+1) bot mk_index' prods + else do poke (ptr `plusPtr` ((#size PgfProduction)*bot)) c_prod + pokeProductions c_ccat ptr top (bot-1) mk_index' prods + + pokeRefDefFunId funs_ptr ptr funid = do + let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun)) + (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun + poke ptr c_fun + + pokeCncCat c_ccats ptr (name,start,end,labels) = do + let n_lins = fromIntegral (length labels) :: CSizeT + c_cnccat <- gu_malloc_aligned pool + ((#size PgfCncCat)+n_lins*(#size GuString)) + (#const gu_flex_alignof(PgfCncCat)) + case Map.lookup name abscats of + Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat + Nothing -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax")) + c_ccats <- newSequence (#size PgfCCat*) pokeFId [start..end] pool + (#poke PgfCncCat, cats) c_cnccat c_ccats + pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels + poke ptr c_cnccat + where + pokeFId ptr fid = do + c_ccat <- getCCat c_ccats fid pool + poke ptr c_ccat + + pokeLabels ptr [] = return [] + pokeLabels ptr (l:ls) = do + c_l <- newUtf8CString l pool + poke ptr c_l + pokeLabels (ptr `plusPtr` (#size GuString)) ls + + +newPGF :: (?builder :: Builder s) => [(String,Literal)] -> + AbsName -> + AbstrInfo -> + [(ConcName,ConcrInfo)] -> + B s PGF +newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs = + unsafePerformIO $ do + ptr <- gu_malloc_aligned pool + (#size PgfPGF) + (#const gu_alignof(PgfPGF)) + c_gflags <- newFlags gflags pool + c_absname <- newUtf8CString absname pool + let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract) + c_concrs <- newSequence (#size PgfConcr) (pokeConcr c_abstr) concrs pool + (#poke PgfPGF, major_version) ptr (2 :: (#type uint16_t)) + (#poke PgfPGF, minor_version) ptr (0 :: (#type uint16_t)) + (#poke PgfPGF, gflags) ptr c_gflags + (#poke PgfPGF, abstract.name) ptr c_absname + (#poke PgfPGF, abstract.aflags) ptr c_aflags + (#poke PgfPGF, abstract.funs) ptr c_funs + (#poke PgfPGF, abstract.cats) ptr c_cats + (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun + (#poke PgfPGF, concretes) ptr c_concrs + (#poke PgfPGF, pool) ptr pool + return (B (PGF ptr touch)) + where + (Builder pool touch) = ?builder + + pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do + c_name <- newUtf8CString name pool + c_fun_indices <- gu_make_map (#size GuString) gu_string_hasher + (#size PgfCncOverloadMap*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + c_coerce_idx <- gu_make_map (#size PgfCCat*) gu_addr_hasher + (#size GuBuf*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + (#poke PgfConcr, name) ptr c_name + (#poke PgfConcr, abstr) ptr c_abstr + (#poke PgfConcr, cflags) ptr c_cflags + (#poke PgfConcr, printnames) ptr c_printnames + (#poke PgfConcr, ccats) ptr c_ccats + (#poke PgfConcr, fun_indices) ptr c_fun_indices + (#poke PgfConcr, coerce_idx) ptr c_coerce_idx + (#poke PgfConcr, cncfuns) ptr c_cncfuns + (#poke PgfConcr, sequences) ptr c_seqs + (#poke PgfConcr, cnccats) ptr c_cnccats + (#poke PgfConcr, total_cats) ptr c_total_cats + (#poke PgfConcr, pool) ptr nullPtr + mk_index ptr pool + + +newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq) +newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool + where + pokeFlag c_flag (name,value) = 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 + + +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_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_alignof(PgfLiteralFlt)) + pptr pool + (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble) + peek pptr + + +newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((#type bool), GuVariant) +newProduction c_ccats funs_ptr c_non_lexical_buf (PApply fun_id args) pool = + alloca $ \pptr -> do + let c_fun = funs_ptr `plusPtr` (fun_id * (#size PgfCncFun)) + c_args <- newSequence (#size PgfPArg) pokePArg args pool + ptr <- gu_alloc_variant (#const PGF_PRODUCTION_APPLY) + (fromIntegral (#size PgfProductionApply)) + (#const gu_alignof(PgfProductionApply)) + pptr pool + (#poke PgfProductionApply, fun) ptr c_fun + (#poke PgfProductionApply, args) ptr c_args + is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool + c_prod <- peek pptr + return (is_lexical,c_prod) + where + pokePArg ptr (PArg hypos ccat) = do + c_ccat <- getCCat c_ccats ccat pool + (#poke PgfPArg, ccat) ptr c_ccat + c_hypos <- newSequence (#size PgfCCat*) pokeCCat hypos pool + (#poke PgfPArg, hypos) ptr c_hypos + + pokeCCat ptr ccat = do + c_ccat <- getCCat c_ccats ccat pool + poke ptr c_ccat + +newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_PRODUCTION_COERCE) + (fromIntegral (#size PgfProductionCoerce)) + (#const gu_alignof(PgfProductionCoerce)) + pptr pool + c_ccat <- getCCat c_ccats fid pool + (#poke PgfProductionCoerce, coerce) ptr c_ccat + c_prod <- peek pptr + return (0,c_prod) + + +newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool = + do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns) + c_ep = if c_absfun == nullPtr + then nullPtr + else c_absfun `plusPtr` (#offset PgfAbsFun, ep) + n_lins = fromIntegral (length seqids) :: CSizeT + ptr <- gu_malloc_aligned pool + ((#size PgfCncFun)+n_lins*(#size PgfSequence*)) + (#const gu_flex_alignof(PgfCncFun)) + (#poke PgfCncFun, absfun) ptr c_absfun + (#poke PgfCncFun, ep) ptr c_ep + (#poke PgfCncFun, funid) ptr (funid :: CInt) + (#poke PgfCncFun, n_lins) ptr n_lins + pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids + return ptr + where + pokeSequences seqs_ptr ptr [] = return () + pokeSequences seqs_ptr ptr (seqid:seqids) = do + poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence))) + pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids + +getCCat c_ccats fid pool = + alloca $ \pfid -> do + poke pfid (fromIntegral fid :: CInt) + ptr <- gu_map_find_default c_ccats pfid + c_ccat <- peek ptr + if c_ccat /= nullPtr + then return c_ccat + else do c_ccat <- gu_malloc_aligned pool + (#size PgfCCat) + (#const gu_alignof(PgfCCat)) + (#poke PgfCCat, cnccat) c_ccat nullPtr + (#poke PgfCCat, lindefs) c_ccat nullPtr + (#poke PgfCCat, linrefs) c_ccat nullPtr + (#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT) + (#poke PgfCCat, prods) c_ccat nullPtr + (#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat) + (#poke PgfCCat, fid) c_ccat fid + (#poke PgfCCat, conts) c_ccat nullPtr + (#poke PgfCCat, answers) c_ccat nullPtr + ptr <- gu_map_insert c_ccats pfid + poke ptr c_ccat + return c_ccat + +newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant +newSymbol (SymCat d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT) + (fromIntegral (#size PgfSymbolCat)) + (#const gu_alignof(PgfSymbolCat)) + pptr pool + (#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymLit d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT) + (fromIntegral (#size PgfSymbolLit)) + (#const gu_alignof(PgfSymbolLit)) + pptr pool + (#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymVar d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR) + (fromIntegral (#size PgfSymbolVar)) + (#const gu_alignof(PgfSymbolVar)) + pptr pool + (#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymKS t) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS) + (fromIntegral ((#size PgfSymbolKS)+utf8Length t)) + (#const gu_flex_alignof(PgfSymbolKS)) + pptr pool + pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token)) + peek pptr +newSymbol (SymKP def alts) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP) + (fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative)))) + (#const gu_flex_alignof(PgfSymbolKP)) + pptr pool + c_def <- newSymbols def pool + (#poke PgfSymbolKP, default_form) ptr c_def + pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool + peek pptr +newSymbol SymBIND pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymNE pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE) + (fromIntegral (#size PgfSymbolNE)) + (#const gu_alignof(PgfSymbolNE)) + pptr pool + peek pptr +newSymbol SymSOFT_BIND pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymSOFT_SPACE pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymCAPIT pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT) + (fromIntegral (#size PgfSymbolCAPIT)) + (#const gu_alignof(PgfSymbolCAPIT)) + pptr pool + peek pptr +newSymbol SymALL_CAPIT pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT) + (fromIntegral (#size PgfSymbolCAPIT)) + (#const gu_alignof(PgfSymbolCAPIT)) + pptr pool + peek pptr + +newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool + where + pokeSymbol p_sym sym = do + c_sym <- newSymbol sym pool + poke p_sym c_sym + +pokeAlternatives ptr [] pool = return () +pokeAlternatives ptr ((syms,prefixes):alts) pool = do + c_syms <- newSymbols syms pool + c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool + (#poke PgfAlternative, form) ptr c_syms + (#poke PgfAlternative, prefixes) ptr c_prefixes + pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool + +pokeString pool c_elem str = do + c_str <- newUtf8CString str pool + poke c_elem c_str + +newMap key_size hasher newKey elem_size pokeElem values pool = do + map <- gu_make_map key_size hasher + elem_size gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + insert map values pool + return map + where + insert map [] pool = return () + insert map ((key,elem):values) pool = do + c_key <- newKey key pool + c_elem <- gu_map_insert map c_key + pokeElem c_elem elem + insert map values pool + + +writePGF :: FilePath -> PGF -> IO () +writePGF fpath p = do + pool <- gu_new_pool + exn <- gu_new_exn pool + withCString fpath $ \c_fpath -> + pgf_write (pgf p) c_fpath exn + touchPGF p + failed <- gu_exn_is_raised exn + if failed + then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno + if is_errno + then do perrno <- (#peek GuExn, data.data) exn + errno <- peek perrno + gu_pool_free pool + ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath)) + else do gu_pool_free pool + throwIO (PGFError "The grammar cannot be stored") + else do gu_pool_free pool + return () + +sortByFst = sortBy (\(x,_) (y,_) -> compare x y) +sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) +sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y) diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index ada2b5e03..57e7eeaa9 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -31,7 +31,7 @@ readType str = do c_str <- newUtf8CString str tmpPl guin <- gu_string_in c_str tmpPl exn <- gu_new_exn tmpPl - c_type <- pgf_read_type guin typPl exn + c_type <- pgf_read_type guin typPl tmpPl exn status <- gu_exn_is_raised exn if (not status && c_type /= nullPtr) then do typFPl <- newForeignPtr gu_pool_finalizer typPl @@ -62,10 +62,9 @@ showType scope (Type ty touch) = mkType :: [Hypo] -> CId -> [Expr] -> Type mkType hypos cat exprs = unsafePerformIO $ do typPl <- gu_new_pool - let n_exprs = fromIntegral (length exprs) :: CInt + let n_exprs = fromIntegral (length exprs) :: CSizeT c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr)) - c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) typPl - hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl + c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) hypos typPl (#poke PgfType, hypos) c_type c_hypos ccat <- newUtf8CString cat typPl (#poke PgfType, cid) c_type ccat @@ -73,27 +72,25 @@ mkType hypos cat exprs = unsafePerformIO $ do pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs typFPl <- newForeignPtr gu_pool_finalizer typPl return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl)) - where - pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO () - pokeHypos c_hypo [] typPl = return () - pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do - (#poke PgfHypo, bind_type) c_hypo cbind_type - newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo - (#poke PgfHypo, type) c_hypo c_ty - pokeHypos (plusPtr c_hypo (#size PgfHypo)) hypos typPl - where - cbind_type :: CInt - cbind_type = - case bind_type of - Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) - Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - pokeExprs ptr [] = return () - pokeExprs ptr ((Expr e _):es) = do - poke ptr e - pokeExprs (plusPtr ptr (#size PgfExpr)) es +pokeHypo :: Ptr GuPool -> Ptr a -> Hypo -> IO () +pokeHypo pool c_hypo (bind_type,cid,Type c_ty _) = do + (#poke PgfHypo, bind_type) c_hypo cbind_type + newUtf8CString cid pool >>= (#poke PgfHypo, cid) c_hypo + (#poke PgfHypo, type) c_hypo c_ty + where + cbind_type :: CInt + cbind_type = + case bind_type of + Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) + Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - touchHypo (_,_,ty) = touchType ty +pokeExprs ptr [] = return () +pokeExprs ptr ((Expr e _):es) = do + poke ptr e + pokeExprs (plusPtr ptr (#size PgfExpr)) es + +touchHypo (_,_,ty) = touchType ty -- | Decomposes a type into a list of hypothesises, a category and -- a list of arguments for the category. @@ -125,3 +122,20 @@ unType (Type c_type touch) = unsafePerformIO $ do es <- peekExprs ptr (i+1) n return (Expr e touch : es) | otherwise = return [] + +-- | renders a type as a 'String'. The list +-- of identifiers is the list of all free variables +-- in the type in order reverse to the order +-- of binding. +showContext :: [CId] -> [Hypo] -> String +showContext scope hypos = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl + printCtxt <- newPrintCtxt scope tmpPl + exn <- gu_new_exn tmpPl + pgf_print_context c_hypos printCtxt out exn + mapM_ touchHypo hypos + s <- gu_string_buf_freeze sb tmpPl + peekUtf8CString s |