mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
310 lines
11 KiB
Haskell
310 lines
11 KiB
Haskell
#include <pgf/pgf.h>
|
|
|
|
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
|
|
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
|