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
data Type = Type {typ :: PgfExpr, touchType :: Touch}
type Hypo = (BindType,CId,Type)
instance Show Type where
show = showType []
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
showType :: [CId] -> 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
mkType :: [Hypo] -> CId -> [Expr] -> Type
mkType hypos cat exprs = unsafePerformIO $ do
typPl <- gu_new_pool
let n_exprs = fromIntegral (length exprs) :: CSizeT
c_type <- gu_malloc typPl (((24)) + n_exprs * ((8)))
c_hypos <- newSequence ((24)) (pokeHypo typPl) hypos typPl
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_type c_hypos
ccat <- newUtf8CString cat typPl
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_type ccat
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_type n_exprs
pokeExprs (c_type `plusPtr` ((24))) 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
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_hypo cbind_type
newUtf8CString cid pool >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_hypo
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_hypo c_ty
where
cbind_type :: CInt
cbind_type =
case bind_type of
Explicit -> (0)
Implicit -> (1)
pokeExprs ptr [] = return ()
pokeExprs ptr ((Expr e _):es) = do
poke ptr e
pokeExprs (plusPtr ptr ((8))) es
touchHypo (_,_,ty) = touchType ty
unType :: Type -> ([Hypo],CId,[Expr])
unType (Type c_type touch) = unsafePerformIO $ do
cid <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) c_type >>= peekUtf8CString
c_hypos <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_type
n_hypos <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_hypos
hs <- peekHypos (c_hypos `plusPtr` ((8))) 0 n_hypos
n_exprs <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_type
es <- peekExprs (c_type `plusPtr` ((24))) 0 n_exprs
return (hs,cid,es)
where
peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
peekHypos c_hypo i n
| i < n = do cid <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) c_hypo >>= peekUtf8CString
c_ty <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_hypo
bt <- fmap toBindType (((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_hypo)
hs <- peekHypos (plusPtr c_hypo ((24))) (i+1) n
return ((bt,cid,Type c_ty touch) : hs)
| otherwise = return []
toBindType :: CInt -> BindType
toBindType (0) = Explicit
toBindType (1) = 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 []
showContext :: [CId] -> [Hypo] -> String
showContext scope hypos =
unsafePerformIO $
withGuPool $ \tmpPl ->
do (sb,out) <- newOut tmpPl
c_hypos <- newSequence ((24)) (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