{-# LINE 1 "PGF2/Type.hsc" #-}
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)))
{-# LINE 67 "PGF2/Type.hsc" #-}
c_hypos <- newSequence ((24)) (pokeHypo typPl) hypos typPl
{-# LINE 68 "PGF2/Type.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_type c_hypos
{-# LINE 69 "PGF2/Type.hsc" #-}
ccat <- newUtf8CString cat typPl
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_type ccat
{-# LINE 71 "PGF2/Type.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_type n_exprs
{-# LINE 72 "PGF2/Type.hsc" #-}
pokeExprs (c_type `plusPtr` ((24))) exprs
{-# LINE 73 "PGF2/Type.hsc" #-}
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
{-# LINE 79 "PGF2/Type.hsc" #-}
newUtf8CString cid pool >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_hypo
{-# LINE 80 "PGF2/Type.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_hypo c_ty
{-# LINE 81 "PGF2/Type.hsc" #-}
where
cbind_type :: CInt
cbind_type =
case bind_type of
Explicit -> (0)
{-# LINE 86 "PGF2/Type.hsc" #-}
Implicit -> (1)
{-# LINE 87 "PGF2/Type.hsc" #-}
pokeExprs ptr [] = return ()
pokeExprs ptr ((Expr e _):es) = do
poke ptr e
pokeExprs (plusPtr ptr ((8))) es
{-# LINE 92 "PGF2/Type.hsc" #-}
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
{-# LINE 100 "PGF2/Type.hsc" #-}
c_hypos <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_type
{-# LINE 101 "PGF2/Type.hsc" #-}
n_hypos <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_hypos
{-# LINE 102 "PGF2/Type.hsc" #-}
hs <- peekHypos (c_hypos `plusPtr` ((8))) 0 n_hypos
{-# LINE 103 "PGF2/Type.hsc" #-}
n_exprs <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_type
{-# LINE 104 "PGF2/Type.hsc" #-}
es <- peekExprs (c_type `plusPtr` ((24))) 0 n_exprs
{-# LINE 105 "PGF2/Type.hsc" #-}
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
{-# LINE 110 "PGF2/Type.hsc" #-}
c_ty <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_hypo
{-# LINE 111 "PGF2/Type.hsc" #-}
bt <- fmap toBindType (((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_hypo)
{-# LINE 112 "PGF2/Type.hsc" #-}
hs <- peekHypos (plusPtr c_hypo ((24))) (i+1) n
{-# LINE 113 "PGF2/Type.hsc" #-}
return ((bt,cid,Type c_ty touch) : hs)
| otherwise = return []
toBindType :: CInt -> BindType
toBindType (0) = Explicit
{-# LINE 118 "PGF2/Type.hsc" #-}
toBindType (1) = Implicit
{-# LINE 119 "PGF2/Type.hsc" #-}
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
{-# LINE 136 "PGF2/Type.hsc" #-}
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