mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-04 00:32:51 -06:00
started on the Haskell binding
This commit is contained in:
krangelov
@@ -2,310 +2,3 @@
|
||||
|
||||
module PGF2.Expr where
|
||||
|
||||
import System.IO.Unsafe(unsafePerformIO)
|
||||
import Foreign hiding (unsafePerformIO)
|
||||
import Foreign.C
|
||||
import Data.IORef
|
||||
import Data.Data
|
||||
import PGF2.FFI
|
||||
import Data.Maybe(fromJust)
|
||||
|
||||
type Cat = String -- ^ Name of syntactic category
|
||||
type Fun = String -- ^ Name of function
|
||||
|
||||
data BindType =
|
||||
Explicit
|
||||
| Implicit
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- Expressions
|
||||
|
||||
-- The C structure for the expression may point to other structures
|
||||
-- which are allocated from other pools. In order to ensure that
|
||||
-- they are not released prematurely we use the exprMaster to
|
||||
-- store references to other Haskell objects
|
||||
|
||||
data Expr = Expr {expr :: PgfExpr, touchExpr :: Touch}
|
||||
|
||||
instance Show Expr where
|
||||
show = showExpr []
|
||||
|
||||
instance Eq Expr where
|
||||
(Expr e1 e1_touch) == (Expr e2 e2_touch) =
|
||||
unsafePerformIO $ do
|
||||
res <- pgf_expr_eq e1 e2
|
||||
e1_touch >> e2_touch
|
||||
return (res /= 0)
|
||||
|
||||
instance Data Expr where
|
||||
gfoldl f z e = z (fromJust . readExpr) `f` (showExpr [] e)
|
||||
toConstr _ = readExprConstr
|
||||
gunfold k z c = case constrIndex c of
|
||||
1 -> k (z (fromJust . readExpr))
|
||||
_ -> error "gunfold"
|
||||
dataTypeOf _ = exprDataType
|
||||
|
||||
readExprConstr :: Constr
|
||||
readExprConstr = mkConstr exprDataType "(fromJust . readExpr)" [] Prefix
|
||||
|
||||
exprDataType :: DataType
|
||||
exprDataType = mkDataType "PGF2.Expr" [readExprConstr]
|
||||
|
||||
-- | Constructs an expression by lambda abstraction
|
||||
mkAbs :: BindType -> String -> Expr -> Expr
|
||||
mkAbs bind_type var (Expr body bodyTouch) =
|
||||
unsafePerformIO $ do
|
||||
exprPl <- gu_new_pool
|
||||
cvar <- newUtf8CString var exprPl
|
||||
c_expr <- pgf_expr_abs cbind_type cvar body exprPl
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl))
|
||||
where
|
||||
cbind_type =
|
||||
case bind_type of
|
||||
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
|
||||
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
|
||||
|
||||
-- | Decomposes an expression into an abstraction and a body
|
||||
unAbs :: Expr -> Maybe (BindType, String, Expr)
|
||||
unAbs (Expr expr touch) =
|
||||
unsafePerformIO $ do
|
||||
c_abs <- pgf_expr_unabs expr
|
||||
if c_abs == nullPtr
|
||||
then return Nothing
|
||||
else do bt <- fmap toBindType ((#peek PgfExprAbs, bind_type) c_abs)
|
||||
var <- (#peek PgfExprAbs, id) c_abs >>= peekUtf8CString
|
||||
c_body <- (#peek PgfExprAbs, body) c_abs
|
||||
return (Just (bt, var, Expr c_body touch))
|
||||
where
|
||||
toBindType :: CInt -> BindType
|
||||
toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
|
||||
toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
|
||||
|
||||
-- | Constructs an expression by applying a function to a list of expressions
|
||||
mkApp :: Fun -> [Expr] -> Expr
|
||||
mkApp fun args =
|
||||
unsafePerformIO $
|
||||
withCString fun $ \cfun ->
|
||||
allocaBytes ((#size PgfApplication) + len * sizeOf (undefined :: PgfExpr)) $ \papp -> do
|
||||
(#poke PgfApplication, fun) papp cfun
|
||||
(#poke PgfApplication, n_args) papp len
|
||||
pokeArray (papp `plusPtr` (#offset PgfApplication, args)) (map expr args)
|
||||
exprPl <- gu_new_pool
|
||||
c_expr <- pgf_expr_apply papp exprPl
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (mapM_ touchExpr args >> touchForeignPtr exprFPl))
|
||||
where
|
||||
len = length args
|
||||
|
||||
-- | Decomposes an expression into an application of a function
|
||||
unApp :: Expr -> Maybe (Fun,[Expr])
|
||||
unApp (Expr expr touch) =
|
||||
unsafePerformIO $
|
||||
withGuPool $ \pl -> do
|
||||
appl <- pgf_expr_unapply expr pl
|
||||
if appl == nullPtr
|
||||
then return Nothing
|
||||
else do
|
||||
fun <- peekCString =<< (#peek PgfApplication, fun) appl
|
||||
arity <- (#peek PgfApplication, n_args) appl :: IO CInt
|
||||
c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
|
||||
return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])
|
||||
|
||||
-- | Decomposes an expression into an application of a function
|
||||
unapply :: Expr -> (Expr,[Expr])
|
||||
unapply (Expr expr touch) =
|
||||
unsafePerformIO $
|
||||
withGuPool $ \pl -> do
|
||||
appl <- pgf_expr_unapply_ex expr pl
|
||||
efun <- (#peek PgfApplication, efun) appl
|
||||
arity <- (#peek PgfApplication, n_args) appl :: IO CInt
|
||||
c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
|
||||
return (Expr efun touch, [Expr c_arg touch | c_arg <- c_args])
|
||||
|
||||
-- | Constructs an expression from a string literal
|
||||
mkStr :: String -> Expr
|
||||
mkStr str =
|
||||
unsafePerformIO $
|
||||
withCString str $ \cstr -> do
|
||||
exprPl <- gu_new_pool
|
||||
c_expr <- pgf_expr_string cstr exprPl
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (touchForeignPtr exprFPl))
|
||||
|
||||
-- | Decomposes an expression into a string literal
|
||||
unStr :: Expr -> Maybe String
|
||||
unStr (Expr expr touch) =
|
||||
unsafePerformIO $ do
|
||||
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_STR)
|
||||
if plit == nullPtr
|
||||
then return Nothing
|
||||
else do s <- peekUtf8CString (plit `plusPtr` (#offset PgfLiteralStr, val))
|
||||
touch
|
||||
return (Just s)
|
||||
|
||||
-- | Constructs an expression from an integer literal.
|
||||
-- Note that the C runtime does not support long integers, and you may run into overflow issues with large values.
|
||||
-- See [here](https://github.com/GrammaticalFramework/gf-core/issues/109) for more details.
|
||||
mkInt :: Int -> Expr
|
||||
mkInt val =
|
||||
unsafePerformIO $ do
|
||||
exprPl <- gu_new_pool
|
||||
c_expr <- pgf_expr_int (fromIntegral val) exprPl
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (touchForeignPtr exprFPl))
|
||||
|
||||
-- | Decomposes an expression into an integer literal
|
||||
unInt :: Expr -> Maybe Int
|
||||
unInt (Expr expr touch) =
|
||||
unsafePerformIO $ do
|
||||
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_INT)
|
||||
if plit == nullPtr
|
||||
then return Nothing
|
||||
else do n <- peek (plit `plusPtr` (#offset PgfLiteralInt, val))
|
||||
touch
|
||||
return (Just (fromIntegral (n :: CInt)))
|
||||
|
||||
-- | Constructs an expression from a real number
|
||||
mkFloat :: Double -> Expr
|
||||
mkFloat val =
|
||||
unsafePerformIO $ do
|
||||
exprPl <- gu_new_pool
|
||||
c_expr <- pgf_expr_float (realToFrac val) exprPl
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (touchForeignPtr exprFPl))
|
||||
|
||||
-- | Decomposes an expression into a real number literal
|
||||
unFloat :: Expr -> Maybe Double
|
||||
unFloat (Expr expr touch) =
|
||||
unsafePerformIO $ do
|
||||
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_FLT)
|
||||
if plit == nullPtr
|
||||
then return Nothing
|
||||
else do n <- peek (plit `plusPtr` (#offset PgfLiteralFlt, val))
|
||||
touch
|
||||
return (Just (realToFrac (n :: CDouble)))
|
||||
|
||||
-- | Constructs a meta variable as an expression
|
||||
mkMeta :: Int -> Expr
|
||||
mkMeta id =
|
||||
unsafePerformIO $ do
|
||||
exprPl <- gu_new_pool
|
||||
c_expr <- pgf_expr_meta (fromIntegral id) exprPl
|
||||
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return (Expr c_expr (touchForeignPtr exprFPl))
|
||||
|
||||
-- | Decomposes an expression into a meta variable
|
||||
unMeta :: Expr -> Maybe Int
|
||||
unMeta (Expr expr touch) =
|
||||
unsafePerformIO $ do
|
||||
c_meta <- pgf_expr_unmeta expr
|
||||
if c_meta == nullPtr
|
||||
then return Nothing
|
||||
else do id <- (#peek PgfExprMeta, id) c_meta
|
||||
touch
|
||||
return (Just (fromIntegral (id :: CInt)))
|
||||
|
||||
-- | parses a 'String' as an expression
|
||||
readExpr :: String -> Maybe Expr
|
||||
readExpr str =
|
||||
unsafePerformIO $
|
||||
do exprPl <- gu_new_pool
|
||||
withGuPool $ \tmpPl ->
|
||||
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 tmpPl exn
|
||||
status <- gu_exn_is_raised exn
|
||||
if (not status && c_expr /= nullPtr)
|
||||
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
|
||||
return $ Just (Expr c_expr (touchForeignPtr exprFPl))
|
||||
else do gu_pool_free exprPl
|
||||
return Nothing
|
||||
|
||||
pIdent :: ReadS String
|
||||
pIdent str =
|
||||
unsafePerformIO $
|
||||
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 tmpPl tmpPl exn
|
||||
c_ident <- pgf_expr_parser_ident c_parser
|
||||
status <- gu_exn_is_raised exn
|
||||
if (not status && c_ident /= nullPtr)
|
||||
then do ident <- peekUtf8CString c_ident
|
||||
(str,_,_) <- readIORef ref
|
||||
return [(ident,str)]
|
||||
else do return []
|
||||
|
||||
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 []
|
||||
|
||||
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
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_expr_parser_ident"
|
||||
pgf_expr_parser_ident :: Ptr PgfExprParser -> IO CString
|
||||
|
||||
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
|
||||
-- of binding.
|
||||
showExpr :: [String] -> Expr -> String
|
||||
showExpr scope e =
|
||||
unsafePerformIO $
|
||||
withGuPool $ \tmpPl ->
|
||||
do (sb,out) <- newOut tmpPl
|
||||
printCtxt <- newPrintCtxt scope tmpPl
|
||||
exn <- gu_new_exn tmpPl
|
||||
pgf_print_expr (expr e) printCtxt 1 out exn
|
||||
touchExpr e
|
||||
s <- gu_string_buf_freeze sb tmpPl
|
||||
peekUtf8CString s
|
||||
|
||||
newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
|
||||
newPrintCtxt [] pool = return nullPtr
|
||||
newPrintCtxt (x:xs) pool = do
|
||||
pctxt <- gu_malloc pool (#size PgfPrintContext)
|
||||
newUtf8CString x pool >>= (#poke PgfPrintContext, name) pctxt
|
||||
newPrintCtxt xs pool >>= (#poke PgfPrintContext, next) pctxt
|
||||
return pctxt
|
||||
|
||||
@@ -2,568 +2,26 @@
|
||||
|
||||
module PGF2.FFI where
|
||||
|
||||
#include <gu/defs.h>
|
||||
#include <gu/hash.h>
|
||||
#include <gu/utf8.h>
|
||||
#include <pgf/pgf.h>
|
||||
#include <pgf/data.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
|
||||
import Data.Word
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Touch = IO ()
|
||||
|
||||
-- | An abstract data type representing multilingual grammar
|
||||
-- in Portable Grammar Format.
|
||||
data PGF = PGF {pgf :: Ptr PgfPGF, langs :: Map.Map String Concr, touchPGF :: Touch}
|
||||
data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch}
|
||||
|
||||
------------------------------------------------------------------
|
||||
-- libgu API
|
||||
|
||||
data GuEnum
|
||||
data GuExn
|
||||
data GuIn
|
||||
data GuOut
|
||||
data GuKind
|
||||
data GuType
|
||||
data GuStringBuf
|
||||
data GuMap
|
||||
data GuMapItor
|
||||
data GuHasher
|
||||
data GuSeq
|
||||
data GuBuf
|
||||
data GuPool
|
||||
type GuVariant = Ptr ()
|
||||
type GuHash = (#type GuHash)
|
||||
type GuUCS = (#type GuUCS)
|
||||
|
||||
type CSizeT = (#type size_t)
|
||||
type CUInt8 = (#type uint8_t)
|
||||
|
||||
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 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 unsafe "gu/mem.h gu_pool_free"
|
||||
gu_pool_free :: Ptr GuPool -> IO ()
|
||||
|
||||
foreign import ccall unsafe "gu/mem.h &gu_pool_free"
|
||||
gu_pool_finalizer :: FinalizerPtr GuPool
|
||||
|
||||
foreign import ccall unsafe "gu/exn.h gu_new_exn"
|
||||
gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn)
|
||||
|
||||
foreign import ccall unsafe "gu/exn.h gu_exn_is_raised"
|
||||
gu_exn_is_raised :: Ptr GuExn -> IO Bool
|
||||
|
||||
foreign import ccall unsafe "gu/exn.h gu_exn_caught_"
|
||||
gu_exn_caught :: Ptr GuExn -> CString -> IO Bool
|
||||
|
||||
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_GuEOF = Ptr "GuEOF"## :: CString
|
||||
|
||||
gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString
|
||||
|
||||
gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString
|
||||
|
||||
gu_exn_type_PgfParseError = Ptr "PgfParseError"## :: CString
|
||||
|
||||
gu_exn_type_PgfTypeError = Ptr "PgfTypeError"## :: CString
|
||||
|
||||
foreign import ccall unsafe "gu/string.h gu_string_in"
|
||||
gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn)
|
||||
|
||||
foreign import ccall unsafe "gu/string.h gu_new_string_buf"
|
||||
gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf)
|
||||
|
||||
foreign import ccall unsafe "gu/string.h gu_string_buf_out"
|
||||
gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut)
|
||||
|
||||
foreign import ccall unsafe "gu/file.h gu_file_in"
|
||||
gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn)
|
||||
|
||||
foreign import ccall safe "gu/enum.h gu_enum_next"
|
||||
gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
|
||||
|
||||
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 GuUCS
|
||||
|
||||
foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
|
||||
gu_utf8_encode :: GuUCS -> Ptr CString -> IO ()
|
||||
|
||||
foreign import ccall unsafe "gu/seq.h gu_make_seq"
|
||||
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
|
||||
|
||||
newOut :: Ptr GuPool -> IO (Ptr GuStringBuf, Ptr GuOut)
|
||||
newOut pool =
|
||||
do sb <- gu_new_string_buf pool
|
||||
out <- gu_string_buf_out sb
|
||||
return (sb,out)
|
||||
|
||||
peekUtf8CString :: CString -> IO String
|
||||
peekUtf8CString ptr =
|
||||
alloca $ \pptr ->
|
||||
poke pptr ptr >> decode pptr
|
||||
where
|
||||
decode pptr = do
|
||||
x <- gu_utf8_decode pptr
|
||||
if x == 0
|
||||
then return []
|
||||
else do cs <- decode pptr
|
||||
return (((toEnum . fromEnum) x) : cs)
|
||||
|
||||
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
|
||||
where
|
||||
encode [] pptr = do
|
||||
gu_utf8_encode 0 pptr
|
||||
encode (c:cs) pptr = 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
|
||||
|
||||
type FId = Int
|
||||
data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
|
||||
|
||||
peekFId :: Ptr a -> IO FId
|
||||
peekFId c_ccat = do
|
||||
c_fid <- (#peek PgfCCat, fid) c_ccat
|
||||
return (fromIntegral (c_fid :: CInt))
|
||||
|
||||
deRef peekValue ptr = peek ptr >>= peekValue
|
||||
data PGF = PGF {a_pgf :: ForeignPtr PgfPGF, langs :: Map.Map String Concr}
|
||||
data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
|
||||
|
||||
------------------------------------------------------------------
|
||||
-- libpgf API
|
||||
|
||||
data PgfExn
|
||||
data PgfPGF
|
||||
data PgfApplication
|
||||
data PgfConcr
|
||||
type PgfExpr = Ptr ()
|
||||
data PgfExprProb
|
||||
data PgfTokenProb
|
||||
data PgfExprParser
|
||||
data PgfFullFormEntry
|
||||
data PgfMorphoCallback
|
||||
data PgfPrintContext
|
||||
type PgfType = Ptr ()
|
||||
data PgfCallbacksMap
|
||||
data PgfOracleCallback
|
||||
data PgfCncTree
|
||||
data PgfLinFuncs
|
||||
data PgfGraphvizOptions
|
||||
type PgfBindType = (#type PgfBindType)
|
||||
data PgfAbsFun
|
||||
data PgfAbsCat
|
||||
data PgfCCat
|
||||
data PgfCncFun
|
||||
data PgfProductionApply
|
||||
data PgfParsing
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_read"
|
||||
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
|
||||
foreign import ccall "pgf.h pgf_read"
|
||||
pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_write"
|
||||
pgf_write :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> CString -> Ptr GuExn -> IO ()
|
||||
foreign import ccall "&pgf_free"
|
||||
pgf_free_fptr :: FinalizerPtr PgfPGF
|
||||
|
||||
foreign import ccall "pgf/writer.h pgf_concrete_save"
|
||||
pgf_concrete_save :: Ptr PgfConcr -> CString -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_have_same_abstract"
|
||||
pgf_have_same_abstract :: Ptr PgfPGF -> Ptr PgfPGF -> (#type bool)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_abstract_name"
|
||||
pgf_abstract_name :: Ptr PgfPGF -> IO CString
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_iter_languages"
|
||||
pgf_iter_languages :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_get_language"
|
||||
pgf_get_language :: Ptr PgfPGF -> CString -> IO (Ptr PgfConcr)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_concrete_name"
|
||||
pgf_concrete_name :: Ptr PgfConcr -> IO CString
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_concrete_load"
|
||||
pgf_concrete_load :: Ptr PgfConcr -> Ptr GuIn -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_concrete_unload"
|
||||
pgf_concrete_unload :: Ptr PgfConcr -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_language_code"
|
||||
pgf_language_code :: Ptr PgfConcr -> IO CString
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_iter_categories"
|
||||
pgf_iter_categories :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_concrete_fix_internals"
|
||||
pgf_concrete_fix_internals :: Ptr PgfConcr -> IO ()
|
||||
|
||||
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_category_fields"
|
||||
pgf_category_fields :: Ptr PgfConcr -> CString -> Ptr CSize -> IO (Ptr CString)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_iter_functions"
|
||||
pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat"
|
||||
pgf_iter_functions_by_cat :: Ptr PgfPGF -> CString -> Ptr GuMapItor -> Ptr GuExn -> IO ()
|
||||
|
||||
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
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_has_linearization"
|
||||
pgf_has_linearization :: Ptr PgfConcr -> CString -> IO CInt
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_linearize"
|
||||
pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_lzr_concretize"
|
||||
pgf_lzr_concretize :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
|
||||
|
||||
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 -> CSizeT -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_lzr_linearize"
|
||||
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 CSizeT -> Ptr (Ptr CString) -> IO ()
|
||||
|
||||
type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO ()
|
||||
type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CString -> CString -> IO ()
|
||||
type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
|
||||
type BindCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
|
||||
type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO ()
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapSymbolTokenCallback :: SymbolTokenCallback -> IO (FunPtr SymbolTokenCallback)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapPhraseCallback :: PhraseCallback -> IO (FunPtr PhraseCallback)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapSymbolNonExistCallback :: NonExistCallback -> IO (FunPtr NonExistCallback)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapSymbolBindCallback :: BindCallback -> IO (FunPtr BindCallback)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapSymbolMetaCallback :: MetaCallback -> IO (FunPtr MetaCallback)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_align_words"
|
||||
pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_parse_to_chart"
|
||||
pgf_parse_to_chart :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> CSizeT -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfParsing)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_get_parse_roots"
|
||||
pgf_get_parse_roots :: Ptr PgfParsing -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_ccat_to_range"
|
||||
pgf_ccat_to_range :: Ptr PgfParsing -> Ptr PgfCCat -> Ptr GuPool -> IO (Ptr GuSeq)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics"
|
||||
pgf_parse_with_heuristics :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
|
||||
|
||||
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 = CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback)
|
||||
|
||||
type LiteralPredictCallback = CString -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_new_callbacks_map"
|
||||
pgf_new_callbacks_map :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
|
||||
|
||||
foreign import ccall
|
||||
hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO ()
|
||||
|
||||
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)
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapOracleLiteralCallback :: OracleLiteralCallback -> IO (FunPtr OracleLiteralCallback)
|
||||
|
||||
foreign import ccall
|
||||
hspgf_new_oracle_callback :: CString -> FunPtr OracleCallback -> FunPtr OracleCallback -> FunPtr OracleLiteralCallback -> Ptr GuPool -> IO (Ptr PgfOracleCallback)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
|
||||
pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_complete"
|
||||
pgf_complete :: Ptr PgfConcr -> PgfType -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
|
||||
pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_lookup_cohorts"
|
||||
pgf_lookup_cohorts :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuEnum)
|
||||
|
||||
type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapLookupMorphoCallback :: LookupMorphoCallback -> IO (FunPtr LookupMorphoCallback)
|
||||
|
||||
type MapItorCallback = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "wrapper"
|
||||
wrapMapItorCallback :: MapItorCallback -> IO (FunPtr MapItorCallback)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_fullform_lexicon"
|
||||
pgf_fullform_lexicon :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr GuEnum)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_fullform_get_string"
|
||||
pgf_fullform_get_string :: Ptr PgfFullFormEntry -> IO CString
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_fullform_get_analyses"
|
||||
pgf_fullform_get_analyses :: Ptr PgfFullFormEntry -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_apply"
|
||||
pgf_expr_apply :: Ptr PgfApplication -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
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_unapply_ex"
|
||||
pgf_expr_unapply_ex :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_abs"
|
||||
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)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_meta"
|
||||
pgf_expr_meta :: CInt -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_unmeta"
|
||||
pgf_expr_unmeta :: PgfExpr -> IO (Ptr a)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_string"
|
||||
pgf_expr_string :: CString -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_int"
|
||||
pgf_expr_int :: CInt -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_float"
|
||||
pgf_expr_float :: CDouble -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_expr_unlit"
|
||||
pgf_expr_unlit :: PgfExpr -> CInt -> IO (Ptr a)
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_expr_eq"
|
||||
pgf_expr_eq :: PgfExpr -> PgfExpr -> IO CInt
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_type_eq"
|
||||
pgf_type_eq :: PgfType -> PgfType -> IO (#type bool)
|
||||
|
||||
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
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_check_expr"
|
||||
pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_infer_expr"
|
||||
pgf_infer_expr :: Ptr PgfPGF -> Ptr PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO PgfType
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_check_type"
|
||||
pgf_check_type :: Ptr PgfPGF -> Ptr PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_compute"
|
||||
pgf_compute :: Ptr PgfPGF -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
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_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)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_print"
|
||||
pgf_print :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> Ptr GuOut -> Ptr GuExn -> IO ()
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_read_expr"
|
||||
pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_read_type"
|
||||
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 ()
|
||||
|
||||
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) -> 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)
|
||||
|
||||
foreign import ccall "pgf/expr.h pgf_clone_expr"
|
||||
pgf_clone_expr :: PgfExpr -> Ptr GuPool -> IO PgfExpr
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,148 +1,3 @@
|
||||
#include <pgf/pgf.h>
|
||||
|
||||
module PGF2.Type where
|
||||
|
||||
import System.IO.Unsafe(unsafePerformIO)
|
||||
import Foreign hiding (unsafePerformIO)
|
||||
import Foreign.C
|
||||
import qualified Text.PrettyPrint as PP
|
||||
import Data.List(mapAccumL)
|
||||
import PGF2.Expr
|
||||
import PGF2.FFI
|
||||
|
||||
-- The C structure for the expression may point to other structures
|
||||
-- which are allocated from other pools. In order to ensure that
|
||||
-- they are not released prematurely we use the exprMaster to
|
||||
-- store references to other Haskell objects
|
||||
data Type = Type {typ :: PgfExpr, touchType :: Touch}
|
||||
|
||||
-- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis
|
||||
type Hypo = (BindType,String,Type)
|
||||
|
||||
instance Show Type where
|
||||
show = showType []
|
||||
|
||||
instance Eq Type where
|
||||
(Type ty1 ty1_touch) == (Type ty2 ty2_touch) =
|
||||
unsafePerformIO $ do
|
||||
res <- pgf_type_eq ty1 ty2
|
||||
ty1_touch >> ty2_touch
|
||||
return (res /= 0)
|
||||
|
||||
-- | parses a 'String' as a type
|
||||
readType :: String -> Maybe Type
|
||||
readType str =
|
||||
unsafePerformIO $
|
||||
do typPl <- gu_new_pool
|
||||
withGuPool $ \tmpPl ->
|
||||
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 tmpPl exn
|
||||
status <- gu_exn_is_raised exn
|
||||
if (not status && c_type /= nullPtr)
|
||||
then do typFPl <- newForeignPtr gu_pool_finalizer typPl
|
||||
return $ Just (Type c_type (touchForeignPtr typFPl))
|
||||
else do gu_pool_free typPl
|
||||
return Nothing
|
||||
|
||||
-- | 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.
|
||||
showType :: [String] -> Type -> String
|
||||
showType scope (Type ty touch) =
|
||||
unsafePerformIO $
|
||||
withGuPool $ \tmpPl ->
|
||||
do (sb,out) <- newOut tmpPl
|
||||
printCtxt <- newPrintCtxt scope tmpPl
|
||||
exn <- gu_new_exn tmpPl
|
||||
pgf_print_type ty printCtxt 0 out exn
|
||||
touch
|
||||
s <- gu_string_buf_freeze sb tmpPl
|
||||
peekUtf8CString s
|
||||
|
||||
-- | creates a type from a list of hypothesises, a category and
|
||||
-- a list of arguments for the category. The operation
|
||||
-- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create
|
||||
-- @h_1 -> ... -> h_n -> C e_1 ... e_m@
|
||||
mkType :: [Hypo] -> String -> [Expr] -> Type
|
||||
mkType hypos cat exprs = unsafePerformIO $ do
|
||||
typPl <- gu_new_pool
|
||||
let n_exprs = fromIntegral (length exprs) :: CSizeT
|
||||
c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr))
|
||||
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
|
||||
(#poke PgfType, n_exprs) c_type n_exprs
|
||||
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))
|
||||
|
||||
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)
|
||||
|
||||
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.
|
||||
unType :: Type -> ([Hypo],String,[Expr])
|
||||
unType (Type c_type touch) = unsafePerformIO $ do
|
||||
cid <- (#peek PgfType, cid) c_type >>= peekUtf8CString
|
||||
c_hypos <- (#peek PgfType, hypos) c_type
|
||||
n_hypos <- (#peek GuSeq, len) c_hypos
|
||||
hs <- peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos
|
||||
n_exprs <- (#peek PgfType, n_exprs) c_type
|
||||
es <- peekExprs (c_type `plusPtr` (#offset PgfType, exprs)) 0 n_exprs
|
||||
return (hs,cid,es)
|
||||
where
|
||||
peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
|
||||
peekHypos c_hypo i n
|
||||
| i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString
|
||||
c_ty <- (#peek PgfHypo, type) c_hypo
|
||||
bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
|
||||
hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n
|
||||
return ((bt,cid,Type c_ty touch) : hs)
|
||||
| otherwise = return []
|
||||
|
||||
toBindType :: CInt -> BindType
|
||||
toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
|
||||
toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
|
||||
|
||||
peekExprs ptr i n
|
||||
| i < n = do e <- peekElemOff ptr i
|
||||
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 :: [String] -> [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
|
||||
|
||||
Reference in New Issue
Block a user