{-# LINE 1 "PGF2/Expr.hsc" #-}
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 CId = String
wildCId = "_" :: CId
type Cat = CId
type Fun = CId
data BindType =
Explicit
| Implicit
deriving Show
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]
mkAbs :: BindType -> CId -> 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 -> (0)
{-# LINE 74 "PGF2/Expr.hsc" #-}
Implicit -> (1)
{-# LINE 75 "PGF2/Expr.hsc" #-}
unAbs :: Expr -> Maybe (BindType, CId, 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 (((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_abs)
{-# LINE 84 "PGF2/Expr.hsc" #-}
var <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) c_abs >>= peekUtf8CString
{-# LINE 85 "PGF2/Expr.hsc" #-}
c_body <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_abs
{-# LINE 86 "PGF2/Expr.hsc" #-}
return (Just (bt, var, Expr c_body touch))
where
toBindType :: CInt -> BindType
toBindType (0) = Explicit
{-# LINE 90 "PGF2/Expr.hsc" #-}
toBindType (1) = Implicit
{-# LINE 91 "PGF2/Expr.hsc" #-}
mkApp :: Fun -> [Expr] -> Expr
mkApp fun args =
unsafePerformIO $
withCString fun $ \cfun ->
allocaBytes (((16)) + len * sizeOf (undefined :: PgfExpr)) $ \papp -> do
{-# LINE 98 "PGF2/Expr.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) papp cfun
{-# LINE 99 "PGF2/Expr.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) papp len
{-# LINE 100 "PGF2/Expr.hsc" #-}
pokeArray (papp `plusPtr` ((16))) (map expr args)
{-# LINE 101 "PGF2/Expr.hsc" #-}
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
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 =<< ((\hsc_ptr -> peekByteOff hsc_ptr 0)) appl
{-# LINE 118 "PGF2/Expr.hsc" #-}
arity <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) appl :: IO CInt
{-# LINE 119 "PGF2/Expr.hsc" #-}
c_args <- peekArray (fromIntegral arity) (appl `plusPtr` ((16)))
{-# LINE 120 "PGF2/Expr.hsc" #-}
return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])
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))
unStr :: Expr -> Maybe String
unStr (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (0)
{-# LINE 137 "PGF2/Expr.hsc" #-}
if plit == nullPtr
then return Nothing
else do s <- peekUtf8CString (plit `plusPtr` ((0)))
{-# LINE 140 "PGF2/Expr.hsc" #-}
touch
return (Just s)
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))
unInt :: Expr -> Maybe Int
unInt (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (1)
{-# LINE 157 "PGF2/Expr.hsc" #-}
if plit == nullPtr
then return Nothing
else do n <- peek (plit `plusPtr` ((0)))
{-# LINE 160 "PGF2/Expr.hsc" #-}
touch
return (Just (fromIntegral (n :: CInt)))
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))
unFloat :: Expr -> Maybe Double
unFloat (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (2)
{-# LINE 177 "PGF2/Expr.hsc" #-}
if plit == nullPtr
then return Nothing
else do n <- peek (plit `plusPtr` ((0)))
{-# LINE 180 "PGF2/Expr.hsc" #-}
touch
return (Just (realToFrac (n :: CDouble)))
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))
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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_meta
{-# LINE 200 "PGF2/Expr.hsc" #-}
touch
return (Just (fromIntegral (id :: CInt)))
mkCId x = x
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
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 () -> (Word8) -> Ptr GuExn -> IO (Int32)
{-# LINE 242 "PGF2/Expr.hsc" #-}
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 -> (Word8) -> IO PgfExpr
{-# LINE 259 "PGF2/Expr.hsc" #-}
type ParserGetc = Ptr () -> (Word8) -> Ptr GuExn -> IO (Int32)
{-# LINE 261 "PGF2/Expr.hsc" #-}
foreign import ccall "wrapper"
wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc)
showExpr :: [CId] -> 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 ((16))
{-# LINE 285 "PGF2/Expr.hsc" #-}
newUtf8CString x pool >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) pctxt
{-# LINE 286 "PGF2/Expr.hsc" #-}
newPrintCtxt xs pool >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) pctxt
{-# LINE 287 "PGF2/Expr.hsc" #-}
return pctxt