{-# LINE 1 "PGF2/Internal.hsc" #-}
{-# LANGUAGE ImplicitParams, RankNTypes #-}
module PGF2.Internal(
FId,isPredefFId,
FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..),
globalFlags, abstrFlags, concrFlags,
concrTotalCats, concrCategories, concrProductions,
concrTotalFuns, concrFunction,
concrTotalSeqs, concrSequence,
build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo,
AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
PGF(..), Concr(..),
writePGF
) where
import PGF2
import PGF2.FFI
import PGF2.Expr
import PGF2.Type
import System.IO.Unsafe(unsafePerformIO)
import Foreign
import Foreign.C
import Data.IORef
import Data.Maybe(fromMaybe)
import Data.List(sortBy)
import Control.Exception(Exception,throwIO)
import Control.Monad(foldM)
import qualified Data.Map as Map
type Token = String
type LIndex = Int
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
| SymKS Token
| SymKP [Symbol] [([Symbol],[String])]
| SymBIND
| SymNE
| SymSOFT_BIND
| SymSOFT_SPACE
| SymCAPIT
| SymALL_CAPIT
deriving (Eq,Ord,Show)
data Production
= PApply {-# UNPACK #-} !FunId [PArg]
| PCoerce {-# UNPACK #-} !FId
deriving (Eq,Ord,Show)
type FunId = Int
type SeqId = Int
data Literal =
LStr String
| LInt Int
| LFlt Double
deriving (Eq,Ord,Show)
globalFlags :: PGF -> [(String,Literal)]
globalFlags p = unsafePerformIO $ do
c_flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) (pgf p)
{-# LINE 73 "PGF2/Internal.hsc" #-}
flags <- peekFlags c_flags
touchPGF p
return flags
abstrFlags :: PGF -> [(String,Literal)]
abstrFlags p = unsafePerformIO $ do
c_flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) (pgf p)
{-# LINE 80 "PGF2/Internal.hsc" #-}
flags <- peekFlags c_flags
touchPGF p
return flags
concrFlags :: Concr -> [(String,Literal)]
concrFlags c = unsafePerformIO $ do
c_flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (concr c)
{-# LINE 87 "PGF2/Internal.hsc" #-}
flags <- peekFlags c_flags
touchConcr c
return flags
peekFlags :: Ptr GuSeq -> IO [(String,Literal)]
peekFlags c_flags = do
c_len <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_flags
{-# LINE 94 "PGF2/Internal.hsc" #-}
peekFlags (c_len :: CInt) (c_flags `plusPtr` ((8)))
{-# LINE 95 "PGF2/Internal.hsc" #-}
where
peekFlags 0 ptr = return []
peekFlags c_len ptr = do
name <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr >>= peekUtf8CString
{-# LINE 99 "PGF2/Internal.hsc" #-}
value <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr >>= peekLiteral
{-# LINE 100 "PGF2/Internal.hsc" #-}
flags <- peekFlags (c_len-1) (ptr `plusPtr` ((16)))
{-# LINE 101 "PGF2/Internal.hsc" #-}
return ((name,value):flags)
peekLiteral :: GuVariant -> IO Literal
peekLiteral p = do
tag <- gu_variant_tag p
ptr <- gu_variant_data p
case tag of
(0) -> do { val <- peekUtf8CString (ptr `plusPtr` ((0)));
{-# LINE 109 "PGF2/Internal.hsc" #-}
return (LStr val) }
(1) -> do { val <- peek (ptr `plusPtr` ((0)));
{-# LINE 111 "PGF2/Internal.hsc" #-}
return (LInt (fromIntegral (val :: CInt))) }
(2) -> do { val <- peek (ptr `plusPtr` ((0)));
{-# LINE 113 "PGF2/Internal.hsc" #-}
return (LFlt (realToFrac (val :: CDouble))) }
_ -> error "Unknown literal type in the grammar"
concrTotalCats :: Concr -> FId
concrTotalCats c = unsafePerformIO $ do
c_total_cats <- ((\hsc_ptr -> peekByteOff hsc_ptr 80)) (concr c)
{-# LINE 119 "PGF2/Internal.hsc" #-}
touchConcr c
return (fromIntegral (c_total_cats :: CInt))
concrCategories :: Concr -> [(Cat,FId,FId,[String])]
concrCategories c =
unsafePerformIO $
withGuPool $ \tmpPl ->
allocaBytes ((8)) $ \itor -> do
{-# LINE 127 "PGF2/Internal.hsc" #-}
exn <- gu_new_exn tmpPl
ref <- newIORef []
fptr <- wrapMapItorCallback (getCategories ref)
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) itor fptr
{-# LINE 131 "PGF2/Internal.hsc" #-}
c_cnccats <- ((\hsc_ptr -> peekByteOff hsc_ptr 72)) (concr c)
{-# LINE 132 "PGF2/Internal.hsc" #-}
gu_map_iter c_cnccats itor exn
touchConcr c
freeHaskellFunPtr fptr
cs <- readIORef ref
return (reverse cs)
where
getCategories ref itor key value exn = do
names <- readIORef ref
name <- peekUtf8CString (castPtr key)
c_cnccat <- peek (castPtr value)
c_cats <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) c_cnccat
{-# LINE 143 "PGF2/Internal.hsc" #-}
c_len <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_cats
{-# LINE 144 "PGF2/Internal.hsc" #-}
first <- peek (c_cats `plusPtr` ((8))) >>= peekFId
{-# LINE 145 "PGF2/Internal.hsc" #-}
last <- peek (c_cats `plusPtr` (((8)) + (fromIntegral (c_len-1::CSizeT))*((8)))) >>= peekFId
{-# LINE 146 "PGF2/Internal.hsc" #-}
c_n_lins <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_cnccat
{-# LINE 147 "PGF2/Internal.hsc" #-}
arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` ((24)))
{-# LINE 148 "PGF2/Internal.hsc" #-}
labels <- mapM peekUtf8CString arr
writeIORef ref ((name,first,last,labels) : names)
concrProductions :: Concr -> FId -> [Production]
concrProductions c fid = unsafePerformIO $ do
c_ccats <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) (concr c)
{-# LINE 154 "PGF2/Internal.hsc" #-}
res <- alloca $ \pfid -> do
poke pfid (fromIntegral fid :: CInt)
gu_map_find_default c_ccats pfid >>= peek
if res == nullPtr
then do touchConcr c
return []
else do c_prods <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) res
{-# LINE 161 "PGF2/Internal.hsc" #-}
if c_prods == nullPtr
then do touchConcr c
return []
else do res <- peekSequence (deRef peekProduction) ((8)) c_prods
{-# LINE 165 "PGF2/Internal.hsc" #-}
touchConcr c
return res
where
peekProduction p = do
tag <- gu_variant_tag p
dt <- gu_variant_data p
case tag of
(0) -> do { c_cncfun <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) dt ;
{-# LINE 173 "PGF2/Internal.hsc" #-}
c_funid <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_cncfun ;
{-# LINE 174 "PGF2/Internal.hsc" #-}
c_args <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) dt ;
{-# LINE 175 "PGF2/Internal.hsc" #-}
pargs <- peekSequence peekPArg ((16)) c_args ;
{-# LINE 176 "PGF2/Internal.hsc" #-}
return (PApply (fromIntegral (c_funid :: CInt)) pargs) }
(1)-> do { c_coerce <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) dt ;
{-# LINE 178 "PGF2/Internal.hsc" #-}
fid <- peekFId c_coerce ;
return (PCoerce fid) }
_ -> error "Unknown production type in the grammar"
where
peekPArg ptr = do
c_hypos <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
{-# LINE 184 "PGF2/Internal.hsc" #-}
hypos <- peekSequence (deRef peekFId) ((4)) c_hypos
{-# LINE 185 "PGF2/Internal.hsc" #-}
c_ccat <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
{-# LINE 186 "PGF2/Internal.hsc" #-}
fid <- peekFId c_ccat
return (PArg hypos fid)
concrTotalFuns :: Concr -> FunId
concrTotalFuns c = unsafePerformIO $ do
c_cncfuns <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) (concr c)
{-# LINE 192 "PGF2/Internal.hsc" #-}
c_len <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_cncfuns
{-# LINE 193 "PGF2/Internal.hsc" #-}
touchConcr c
return (fromIntegral (c_len :: CSizeT))
concrFunction :: Concr -> FunId -> (Fun,[SeqId])
concrFunction c funid = unsafePerformIO $ do
c_cncfuns <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) (concr c)
{-# LINE 199 "PGF2/Internal.hsc" #-}
c_cncfun <- peek (c_cncfuns `plusPtr` (((8))+funid*((8))))
{-# LINE 200 "PGF2/Internal.hsc" #-}
c_absfun <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_cncfun
{-# LINE 201 "PGF2/Internal.hsc" #-}
c_name <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_absfun
{-# LINE 202 "PGF2/Internal.hsc" #-}
name <- peekUtf8CString c_name
c_n_lins <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) c_cncfun
{-# LINE 204 "PGF2/Internal.hsc" #-}
arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` ((32)))
{-# LINE 205 "PGF2/Internal.hsc" #-}
seqs_seq <- ((\hsc_ptr -> peekByteOff hsc_ptr 64)) (concr c)
{-# LINE 206 "PGF2/Internal.hsc" #-}
touchConcr c
let seqs = seqs_seq `plusPtr` ((8))
{-# LINE 208 "PGF2/Internal.hsc" #-}
return (name, map (toSeqId seqs) arr)
where
toSeqId seqs seq = minusPtr seq seqs `div` ((16))
{-# LINE 211 "PGF2/Internal.hsc" #-}
concrTotalSeqs :: Concr -> SeqId
concrTotalSeqs c = unsafePerformIO $ do
seq <- ((\hsc_ptr -> peekByteOff hsc_ptr 64)) (concr c)
{-# LINE 215 "PGF2/Internal.hsc" #-}
c_len <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) seq
{-# LINE 216 "PGF2/Internal.hsc" #-}
touchConcr c
return (fromIntegral (c_len :: CSizeT))
concrSequence :: Concr -> SeqId -> [Symbol]
concrSequence c seqid = unsafePerformIO $ do
c_sequences <- ((\hsc_ptr -> peekByteOff hsc_ptr 64)) (concr c)
{-# LINE 222 "PGF2/Internal.hsc" #-}
let c_sequence = c_sequences `plusPtr` (((8))+seqid*((16)))
{-# LINE 223 "PGF2/Internal.hsc" #-}
c_syms <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_sequence
{-# LINE 224 "PGF2/Internal.hsc" #-}
res <- peekSequence (deRef peekSymbol) ((8)) c_syms
{-# LINE 225 "PGF2/Internal.hsc" #-}
touchConcr c
return res
where
peekSymbol p = do
tag <- gu_variant_tag p
dt <- gu_variant_data p
case tag of
(0) -> peekSymbolIdx SymCat dt
{-# LINE 233 "PGF2/Internal.hsc" #-}
(1) -> peekSymbolIdx SymLit dt
{-# LINE 234 "PGF2/Internal.hsc" #-}
(2) -> peekSymbolIdx SymVar dt
{-# LINE 235 "PGF2/Internal.hsc" #-}
(3) -> peekSymbolKS dt
{-# LINE 236 "PGF2/Internal.hsc" #-}
(4) -> peekSymbolKP dt
{-# LINE 237 "PGF2/Internal.hsc" #-}
(5) -> return SymBIND
{-# LINE 238 "PGF2/Internal.hsc" #-}
(6) -> return SymSOFT_BIND
{-# LINE 239 "PGF2/Internal.hsc" #-}
(7) -> return SymNE
{-# LINE 240 "PGF2/Internal.hsc" #-}
(8) -> return SymSOFT_SPACE
{-# LINE 241 "PGF2/Internal.hsc" #-}
(9) -> return SymCAPIT
{-# LINE 242 "PGF2/Internal.hsc" #-}
(10) -> return SymALL_CAPIT
{-# LINE 243 "PGF2/Internal.hsc" #-}
_ -> error "Unknown symbol type in the grammar"
peekSymbolIdx constr dt = do
c_d <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) dt
{-# LINE 247 "PGF2/Internal.hsc" #-}
c_r <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) dt
{-# LINE 248 "PGF2/Internal.hsc" #-}
return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt)))
peekSymbolKS dt = do
token <- peekUtf8CString (dt `plusPtr` ((0)))
{-# LINE 252 "PGF2/Internal.hsc" #-}
return (SymKS token)
peekSymbolKP dt = do
c_default_form <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) dt
{-# LINE 256 "PGF2/Internal.hsc" #-}
default_form <- peekSequence (deRef peekSymbol) ((8)) c_default_form
{-# LINE 257 "PGF2/Internal.hsc" #-}
c_n_forms <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) dt
{-# LINE 258 "PGF2/Internal.hsc" #-}
forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` ((16)))
{-# LINE 259 "PGF2/Internal.hsc" #-}
return (SymKP default_form forms)
peekForms 0 ptr = return []
peekForms len ptr = do
c_form <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
{-# LINE 264 "PGF2/Internal.hsc" #-}
form <- peekSequence (deRef peekSymbol) ((8)) c_form
{-# LINE 265 "PGF2/Internal.hsc" #-}
c_prefixes <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
{-# LINE 266 "PGF2/Internal.hsc" #-}
prefixes <- peekSequence (deRef peekUtf8CString) ((8)) c_prefixes
{-# LINE 267 "PGF2/Internal.hsc" #-}
forms <- peekForms (len-1) (ptr `plusPtr` ((16)))
{-# LINE 268 "PGF2/Internal.hsc" #-}
return ((form,prefixes):forms)
fidString, fidInt, fidFloat, fidVar, fidStart :: FId
fidString = (-1)
fidInt = (-2)
fidFloat = (-3)
fidVar = (-4)
fidStart = (-5)
isPredefFId :: FId -> Bool
isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])
data Builder s = Builder (Ptr GuPool) Touch
newtype B s a = B a
build :: (forall s . (?builder :: Builder s) => B s a) -> a
build f =
unsafePerformIO $ do
pool <- gu_new_pool
poolFPtr <- newForeignPtr gu_pool_finalizer pool
let ?builder = Builder pool (touchForeignPtr poolFPtr)
let B res = f
return res
eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr
eAbs bind_type var (B (Expr body _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (0)
{-# LINE 302 "PGF2/Internal.hsc" #-}
((24))
{-# LINE 303 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 304 "PGF2/Internal.hsc" #-}
pptr pool
cvar <- newUtf8CString var pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (cbind_type :: PgfBindType)
{-# LINE 307 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr cvar
{-# LINE 308 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr body
{-# LINE 309 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
cbind_type =
case bind_type of
Explicit -> (0)
{-# LINE 317 "PGF2/Internal.hsc" #-}
Implicit -> (1)
{-# LINE 318 "PGF2/Internal.hsc" #-}
eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr
eApp (B (Expr fun _)) (B (Expr arg _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (1)
{-# LINE 324 "PGF2/Internal.hsc" #-}
((16))
{-# LINE 325 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 326 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr fun
{-# LINE 328 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr arg
{-# LINE 329 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eMeta :: (?builder :: Builder s) => Int -> B s Expr
eMeta id =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (3)
{-# LINE 339 "PGF2/Internal.hsc" #-}
(fromIntegral ((4)))
{-# LINE 340 "PGF2/Internal.hsc" #-}
(4)
{-# LINE 341 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (fromIntegral id :: CInt)
{-# LINE 343 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eFun :: (?builder :: Builder s) => Fun -> B s Expr
eFun fun =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (4)
{-# LINE 353 "PGF2/Internal.hsc" #-}
(fromIntegral (((0))+utf8Length fun))
{-# LINE 354 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 355 "PGF2/Internal.hsc" #-}
pptr pool
pokeUtf8CString fun (ptr `plusPtr` ((0)))
{-# LINE 357 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eVar :: (?builder :: Builder s) => Int -> B s Expr
eVar var =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (5)
{-# LINE 367 "PGF2/Internal.hsc" #-}
((4))
{-# LINE 368 "PGF2/Internal.hsc" #-}
(4)
{-# LINE 369 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (fromIntegral var :: CInt)
{-# LINE 371 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr
eTyped (B (Expr e _)) (B (Type ty _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (6)
{-# LINE 381 "PGF2/Internal.hsc" #-}
((16))
{-# LINE 382 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 383 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr e
{-# LINE 385 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr ty
{-# LINE 386 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr
eImplArg (B (Expr e _)) =
unsafePerformIO $
alloca $ \pptr -> do
ptr <- gu_alloc_variant (7)
{-# LINE 396 "PGF2/Internal.hsc" #-}
((8))
{-# LINE 397 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 398 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr e
{-# LINE 400 "PGF2/Internal.hsc" #-}
e <- peek pptr
return (B (Expr e touch))
where
(Builder pool touch) = ?builder
hypo :: BindType -> CId -> B s Type -> (B s Hypo)
hypo bind_type var (B ty) = B (bind_type,var,ty)
dTyp :: (?builder :: Builder s) => [B s Hypo] -> Cat -> [B s Expr] -> B s Type
dTyp hypos cat es =
unsafePerformIO $ do
ptr <- gu_malloc_aligned pool
(((24))+n_exprs*((8)))
{-# LINE 413 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 414 "PGF2/Internal.hsc" #-}
c_hypos <- newHypos hypos pool
c_cat <- newUtf8CString cat pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_hypos
{-# LINE 417 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_cat
{-# LINE 418 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr n_exprs
{-# LINE 419 "PGF2/Internal.hsc" #-}
pokeArray (ptr `plusPtr` ((24))) [e | B (Expr e _) <- es]
{-# LINE 420 "PGF2/Internal.hsc" #-}
return (B (Type ptr touch))
where
(Builder pool touch) = ?builder
n_exprs = fromIntegral (length es) :: CSizeT
newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq)
newHypos hypos pool = do
c_hypos <- gu_make_seq ((24)) (fromIntegral (length hypos)) pool
{-# LINE 428 "PGF2/Internal.hsc" #-}
pokeHypos (c_hypos `plusPtr` ((8))) hypos
{-# LINE 429 "PGF2/Internal.hsc" #-}
return c_hypos
where
pokeHypos ptr [] = return ()
pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do
c_var <- newUtf8CString var pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (cbind_type :: PgfBindType)
{-# LINE 435 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_var
{-# LINE 436 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr ty
{-# LINE 437 "PGF2/Internal.hsc" #-}
pokeHypos (ptr `plusPtr` ((24))) hypos
{-# LINE 438 "PGF2/Internal.hsc" #-}
where
cbind_type =
case bind_type of
Explicit -> (0)
{-# LINE 442 "PGF2/Internal.hsc" #-}
Implicit -> (1)
{-# LINE 443 "PGF2/Internal.hsc" #-}
data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch
newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
[(Cat,[B s Hypo],Float)] ->
[(Fun,B s Type,Int,Float)] ->
AbstrInfo
newAbstr aflags cats funs = unsafePerformIO $ do
c_aflags <- newFlags aflags pool
(c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
(c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
c_abs_lin_fun <- newAbsLinFun
c_non_lexical_buf <- gu_make_buf ((24)) pool
{-# LINE 457 "PGF2/Internal.hsc" #-}
return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch)
where
(Builder pool touch) = ?builder
newAbsCats values pool = do
c_seq <- gu_make_seq ((32)) (fromIntegral (length values)) pool
{-# LINE 463 "PGF2/Internal.hsc" #-}
abscats <- pokeElems (c_seq `plusPtr` ((8))) Map.empty values
{-# LINE 464 "PGF2/Internal.hsc" #-}
return (c_seq,abscats)
where
pokeElems ptr abscats [] = return abscats
pokeElems ptr abscats (x:xs) = do
abscats <- pokeAbsCat ptr abscats x
pokeElems (ptr `plusPtr` ((32))) abscats xs
{-# LINE 470 "PGF2/Internal.hsc" #-}
pokeAbsCat ptr abscats (name,hypos,prob) = do
c_name <- newUtf8CString name pool
c_hypos <- newHypos hypos pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_name
{-# LINE 475 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_hypos
{-# LINE 476 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr (realToFrac prob :: CFloat)
{-# LINE 477 "PGF2/Internal.hsc" #-}
return (Map.insert name ptr abscats)
newAbsFuns values pool = do
c_seq <- gu_make_seq ((72)) (fromIntegral (length values)) pool
{-# LINE 481 "PGF2/Internal.hsc" #-}
absfuns <- pokeElems (c_seq `plusPtr` ((8))) Map.empty values
{-# LINE 482 "PGF2/Internal.hsc" #-}
return (c_seq,absfuns)
where
pokeElems ptr absfuns [] = return absfuns
pokeElems ptr absfuns (x:xs) = do
absfuns <- pokeAbsFun ptr absfuns x
pokeElems (ptr `plusPtr` ((72))) absfuns xs
{-# LINE 488 "PGF2/Internal.hsc" #-}
pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do
pfun <- gu_alloc_variant (4)
{-# LINE 491 "PGF2/Internal.hsc" #-}
(fromIntegral (((0))+utf8Length name))
{-# LINE 492 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 493 "PGF2/Internal.hsc" #-}
(ptr `plusPtr` ((40))) pool
{-# LINE 494 "PGF2/Internal.hsc" #-}
let c_name = (pfun `plusPtr` ((0)))
{-# LINE 495 "PGF2/Internal.hsc" #-}
pokeUtf8CString name c_name
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_name
{-# LINE 497 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_ty
{-# LINE 498 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr (fromIntegral arity :: CInt)
{-# LINE 499 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr nullPtr
{-# LINE 500 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) ptr (realToFrac prob :: CFloat)
{-# LINE 501 "PGF2/Internal.hsc" #-}
return (Map.insert name ptr absfuns)
newAbsLinFun = do
ptr <- gu_malloc_aligned pool
((72))
{-# LINE 506 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 507 "PGF2/Internal.hsc" #-}
c_wild <- newUtf8CString "_" pool
c_ty <- gu_malloc_aligned pool
((24))
{-# LINE 510 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 511 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_ty nullPtr
{-# LINE 512 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_ty c_wild
{-# LINE 513 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_ty (0 :: CSizeT)
{-# LINE 514 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_wild
{-# LINE 515 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_ty
{-# LINE 516 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr (0 :: CSizeT)
{-# LINE 517 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr nullPtr
{-# LINE 518 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) ptr (- log 0 :: CFloat)
{-# LINE 519 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) ptr nullPtr
{-# LINE 520 "PGF2/Internal.hsc" #-}
return ptr
data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt
newConcr :: (?builder :: Builder s) => AbstrInfo
-> [(String,Literal)]
-> [(String,String)]
-> [(FId,[FunId])]
-> [(FId,[FunId])]
-> [(FId,[Production])]
-> [(Fun,[SeqId])]
-> [[Symbol]]
-> [(Cat,FId,FId,[String])]
-> FId
-> ConcrInfo
newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do
c_cflags <- newFlags cflags pool
c_printname <- newMap ((8)) gu_string_hasher newUtf8CString
{-# LINE 539 "PGF2/Internal.hsc" #-}
((8)) (pokeString pool)
{-# LINE 540 "PGF2/Internal.hsc" #-}
printnames pool
c_seqs <- newSequence ((16)) pokeSequence sequences pool
{-# LINE 542 "PGF2/Internal.hsc" #-}
let seqs_ptr = c_seqs `plusPtr` ((8))
{-# LINE 543 "PGF2/Internal.hsc" #-}
c_cncfuns <- newSequence ((8)) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool
{-# LINE 544 "PGF2/Internal.hsc" #-}
let funs_ptr = c_cncfuns `plusPtr` ((8))
{-# LINE 545 "PGF2/Internal.hsc" #-}
c_ccats <- gu_make_map ((4)) gu_int_hasher
{-# LINE 546 "PGF2/Internal.hsc" #-}
((8)) gu_null_struct
{-# LINE 547 "PGF2/Internal.hsc" #-}
(11)
{-# LINE 548 "PGF2/Internal.hsc" #-}
pool
mapM_ (addLindefs c_ccats funs_ptr) lindefs
mapM_ (addLinrefs c_ccats funs_ptr) linrefs
mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods
c_cnccats <- newMap ((8)) gu_string_hasher newUtf8CString ((8)) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool
{-# LINE 553 "PGF2/Internal.hsc" #-}
return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats))
where
(Builder pool touch) = ?builder
pokeCncFun seqs_ptr ptr cncfun = do
c_cncfun <- newCncFun absfuns nullPtr cncfun pool
poke ptr c_cncfun
pokeSequence c_seq syms = do
c_syms <- newSymbols syms pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_seq c_syms
{-# LINE 564 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_seq nullPtr
{-# LINE 565 "PGF2/Internal.hsc" #-}
addLindefs c_ccats funs_ptr (fid,funids) = do
c_ccat <- getCCat c_ccats fid pool
c_funs <- newSequence ((8)) (pokeRefDefFunId funs_ptr) funids pool
{-# LINE 569 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_ccat c_funs
{-# LINE 570 "PGF2/Internal.hsc" #-}
addLinrefs c_ccats funs_ptr (fid,funids) = do
c_ccat <- getCCat c_ccats fid pool
c_funs <- newSequence ((8)) (pokeRefDefFunId funs_ptr) funids pool
{-# LINE 574 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_ccat c_funs
{-# LINE 575 "PGF2/Internal.hsc" #-}
addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do
c_ccat <- getCCat c_ccats fid pool
let n_prods = length prods
c_prods <- gu_make_seq ((8)) (fromIntegral n_prods) pool
{-# LINE 580 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) c_ccat c_prods
{-# LINE 581 "PGF2/Internal.hsc" #-}
pokeProductions c_ccat (c_prods `plusPtr` ((8))) 0 (n_prods-1) mk_index prods
{-# LINE 582 "PGF2/Internal.hsc" #-}
where
pokeProductions c_ccat ptr top bot mk_index [] = return mk_index
pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do
(is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool
let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool
pgf_lzr_index concr c_ccat c_prod is_lexical pool
mk_index concr pool
if is_lexical == 0
then do poke (ptr `plusPtr` (((8))*top)) c_prod
{-# LINE 591 "PGF2/Internal.hsc" #-}
pokeProductions c_ccat ptr (top+1) bot mk_index' prods
else do poke (ptr `plusPtr` (((8))*bot)) c_prod
{-# LINE 593 "PGF2/Internal.hsc" #-}
pokeProductions c_ccat ptr top (bot-1) mk_index' prods
pokeRefDefFunId funs_ptr ptr funid = do
let c_fun = funs_ptr `plusPtr` (funid * ((32)))
{-# LINE 597 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_fun c_abs_lin_fun
{-# LINE 598 "PGF2/Internal.hsc" #-}
poke ptr c_fun
pokeCncCat c_ccats ptr (name,start,end,labels) = do
let n_lins = fromIntegral (length labels) :: CSizeT
c_cnccat <- gu_malloc_aligned pool
(((24))+n_lins*((8)))
{-# LINE 604 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 605 "PGF2/Internal.hsc" #-}
case Map.lookup name abscats of
Just c_abscat -> ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_cnccat c_abscat
{-# LINE 607 "PGF2/Internal.hsc" #-}
Nothing -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax"))
c_ccats <- newSequence ((8)) pokeFId [start..end] pool
{-# LINE 609 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_cnccat c_ccats
{-# LINE 610 "PGF2/Internal.hsc" #-}
pokeLabels (c_cnccat `plusPtr` ((24))) labels
{-# LINE 611 "PGF2/Internal.hsc" #-}
poke ptr c_cnccat
where
pokeFId ptr fid = do
c_ccat <- getCCat c_ccats fid pool
poke ptr c_ccat
pokeLabels ptr [] = return []
pokeLabels ptr (l:ls) = do
c_l <- newUtf8CString l pool
poke ptr c_l
pokeLabels (ptr `plusPtr` ((8))) ls
{-# LINE 622 "PGF2/Internal.hsc" #-}
newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
AbsName ->
AbstrInfo ->
[(ConcName,ConcrInfo)] ->
B s PGF
newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs =
unsafePerformIO $ do
ptr <- gu_malloc_aligned pool
((80))
{-# LINE 633 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 634 "PGF2/Internal.hsc" #-}
c_gflags <- newFlags gflags pool
c_absname <- newUtf8CString absname pool
let c_abstr = ptr `plusPtr` ((16))
{-# LINE 637 "PGF2/Internal.hsc" #-}
c_concrs <- newSequence ((104)) (pokeConcr c_abstr) concrs pool
{-# LINE 638 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (2 :: (Word16))
{-# LINE 639 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 2)) ptr (0 :: (Word16))
{-# LINE 640 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_gflags
{-# LINE 641 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr c_absname
{-# LINE 642 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr c_aflags
{-# LINE 643 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) ptr c_funs
{-# LINE 644 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) ptr c_cats
{-# LINE 645 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) ptr c_abs_lin_fun
{-# LINE 646 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 64)) ptr c_concrs
{-# LINE 647 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 72)) ptr pool
{-# LINE 648 "PGF2/Internal.hsc" #-}
return (B (PGF ptr touch))
where
(Builder pool touch) = ?builder
pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do
c_name <- newUtf8CString name pool
c_fun_indices <- gu_make_map ((8)) gu_string_hasher
{-# LINE 655 "PGF2/Internal.hsc" #-}
((8)) gu_null_struct
{-# LINE 656 "PGF2/Internal.hsc" #-}
(11)
{-# LINE 657 "PGF2/Internal.hsc" #-}
pool
c_coerce_idx <- gu_make_map ((8)) gu_addr_hasher
{-# LINE 659 "PGF2/Internal.hsc" #-}
((8)) gu_null_struct
{-# LINE 660 "PGF2/Internal.hsc" #-}
(11)
{-# LINE 661 "PGF2/Internal.hsc" #-}
pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_name
{-# LINE 663 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_abstr
{-# LINE 664 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr c_cflags
{-# LINE 665 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr c_printnames
{-# LINE 666 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) ptr c_ccats
{-# LINE 667 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) ptr c_fun_indices
{-# LINE 668 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) ptr c_coerce_idx
{-# LINE 669 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) ptr c_cncfuns
{-# LINE 670 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 64)) ptr c_seqs
{-# LINE 671 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 72)) ptr c_cnccats
{-# LINE 672 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 80)) ptr c_total_cats
{-# LINE 673 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 88)) ptr nullPtr
{-# LINE 674 "PGF2/Internal.hsc" #-}
mk_index ptr pool
newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq)
newFlags flags pool = newSequence ((16)) pokeFlag (sortByFst flags) pool
{-# LINE 679 "PGF2/Internal.hsc" #-}
where
pokeFlag c_flag (name,value) = do
c_name <- newUtf8CString name pool
c_value <- newLiteral value pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_flag c_name
{-# LINE 684 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_flag c_value
{-# LINE 685 "PGF2/Internal.hsc" #-}
newLiteral :: Literal -> Ptr GuPool -> IO GuVariant
newLiteral (LStr val) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (0)
{-# LINE 691 "PGF2/Internal.hsc" #-}
(fromIntegral (((0))+utf8Length val))
{-# LINE 692 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 693 "PGF2/Internal.hsc" #-}
pptr pool
pokeUtf8CString val (ptr `plusPtr` ((0)))
{-# LINE 695 "PGF2/Internal.hsc" #-}
peek pptr
newLiteral (LInt val) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (1)
{-# LINE 699 "PGF2/Internal.hsc" #-}
(fromIntegral ((4)))
{-# LINE 700 "PGF2/Internal.hsc" #-}
(4)
{-# LINE 701 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (fromIntegral val :: CInt)
{-# LINE 703 "PGF2/Internal.hsc" #-}
peek pptr
newLiteral (LFlt val) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (2)
{-# LINE 707 "PGF2/Internal.hsc" #-}
(fromIntegral ((8)))
{-# LINE 708 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 709 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (realToFrac val :: CDouble)
{-# LINE 711 "PGF2/Internal.hsc" #-}
peek pptr
newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((Word8), GuVariant)
{-# LINE 715 "PGF2/Internal.hsc" #-}
newProduction c_ccats funs_ptr c_non_lexical_buf (PApply fun_id args) pool =
alloca $ \pptr -> do
let c_fun = funs_ptr `plusPtr` (fun_id * ((32)))
{-# LINE 718 "PGF2/Internal.hsc" #-}
c_args <- newSequence ((16)) pokePArg args pool
{-# LINE 719 "PGF2/Internal.hsc" #-}
ptr <- gu_alloc_variant (0)
{-# LINE 720 "PGF2/Internal.hsc" #-}
(fromIntegral ((16)))
{-# LINE 721 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 722 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_fun
{-# LINE 724 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_args
{-# LINE 725 "PGF2/Internal.hsc" #-}
is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool
c_prod <- peek pptr
return (is_lexical,c_prod)
where
pokePArg ptr (PArg hypos ccat) = do
c_ccat <- getCCat c_ccats ccat pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_ccat
{-# LINE 732 "PGF2/Internal.hsc" #-}
c_hypos <- newSequence ((8)) pokeCCat hypos pool
{-# LINE 733 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_hypos
{-# LINE 734 "PGF2/Internal.hsc" #-}
pokeCCat ptr ccat = do
c_ccat <- getCCat c_ccats ccat pool
poke ptr c_ccat
newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool =
alloca $ \pptr -> do
ptr <- gu_alloc_variant (1)
{-# LINE 742 "PGF2/Internal.hsc" #-}
(fromIntegral ((8)))
{-# LINE 743 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 744 "PGF2/Internal.hsc" #-}
pptr pool
c_ccat <- getCCat c_ccats fid pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_ccat
{-# LINE 747 "PGF2/Internal.hsc" #-}
c_prod <- peek pptr
return (0,c_prod)
newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
c_ep = if c_absfun == nullPtr
then nullPtr
else c_absfun `plusPtr` ((32))
{-# LINE 756 "PGF2/Internal.hsc" #-}
n_lins = fromIntegral (length seqids) :: CSizeT
ptr <- gu_malloc_aligned pool
(((32))+n_lins*((8)))
{-# LINE 759 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 760 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_absfun
{-# LINE 761 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_ep
{-# LINE 762 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr (funid :: CInt)
{-# LINE 763 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr n_lins
{-# LINE 764 "PGF2/Internal.hsc" #-}
pokeSequences seqs_ptr (ptr `plusPtr` ((32))) seqids
{-# LINE 765 "PGF2/Internal.hsc" #-}
return ptr
where
pokeSequences seqs_ptr ptr [] = return ()
pokeSequences seqs_ptr ptr (seqid:seqids) = do
poke ptr (seqs_ptr `plusPtr` (seqid * ((16))))
{-# LINE 770 "PGF2/Internal.hsc" #-}
pokeSequences seqs_ptr (ptr `plusPtr` ((8))) seqids
{-# LINE 771 "PGF2/Internal.hsc" #-}
getCCat c_ccats fid pool =
alloca $ \pfid -> do
poke pfid (fromIntegral fid :: CInt)
ptr <- gu_map_find_default c_ccats pfid
c_ccat <- peek ptr
if c_ccat /= nullPtr
then return c_ccat
else do c_ccat <- gu_malloc_aligned pool
((72))
{-# LINE 781 "PGF2/Internal.hsc" #-}
(8)
{-# LINE 782 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) c_ccat nullPtr
{-# LINE 783 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) c_ccat nullPtr
{-# LINE 784 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) c_ccat nullPtr
{-# LINE 785 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) c_ccat (0 :: CSizeT)
{-# LINE 786 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) c_ccat nullPtr
{-# LINE 787 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) c_ccat (0 :: CFloat)
{-# LINE 788 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) c_ccat fid
{-# LINE 789 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) c_ccat nullPtr
{-# LINE 790 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 64)) c_ccat nullPtr
{-# LINE 791 "PGF2/Internal.hsc" #-}
ptr <- gu_map_insert c_ccats pfid
poke ptr c_ccat
return c_ccat
newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
newSymbol (SymCat d r) pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (0)
{-# LINE 798 "PGF2/Internal.hsc" #-}
(fromIntegral ((8)))
{-# LINE 799 "PGF2/Internal.hsc" #-}
(4)
{-# LINE 800 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (fromIntegral d :: CInt)
{-# LINE 802 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr (fromIntegral r :: CInt)
{-# LINE 803 "PGF2/Internal.hsc" #-}
peek pptr
newSymbol (SymLit d r) pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (1)
{-# LINE 806 "PGF2/Internal.hsc" #-}
(fromIntegral ((8)))
{-# LINE 807 "PGF2/Internal.hsc" #-}
(4)
{-# LINE 808 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (fromIntegral d :: CInt)
{-# LINE 810 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr (fromIntegral r :: CInt)
{-# LINE 811 "PGF2/Internal.hsc" #-}
peek pptr
newSymbol (SymVar d r) pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (2)
{-# LINE 814 "PGF2/Internal.hsc" #-}
(fromIntegral ((8)))
{-# LINE 815 "PGF2/Internal.hsc" #-}
(4)
{-# LINE 816 "PGF2/Internal.hsc" #-}
pptr pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (fromIntegral d :: CInt)
{-# LINE 818 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr (fromIntegral r :: CInt)
{-# LINE 819 "PGF2/Internal.hsc" #-}
peek pptr
newSymbol (SymKS t) pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (3)
{-# LINE 822 "PGF2/Internal.hsc" #-}
(fromIntegral (((0))+utf8Length t))
{-# LINE 823 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 824 "PGF2/Internal.hsc" #-}
pptr pool
pokeUtf8CString t (ptr `plusPtr` ((0)))
{-# LINE 826 "PGF2/Internal.hsc" #-}
peek pptr
newSymbol (SymKP def alts) pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (4)
{-# LINE 829 "PGF2/Internal.hsc" #-}
(fromIntegral (((16))+(length alts * ((16)))))
{-# LINE 830 "PGF2/Internal.hsc" #-}
(0)
{-# LINE 831 "PGF2/Internal.hsc" #-}
pptr pool
c_def <- newSymbols def pool
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_def
{-# LINE 834 "PGF2/Internal.hsc" #-}
pokeAlternatives (ptr `plusPtr` ((16))) alts pool
{-# LINE 835 "PGF2/Internal.hsc" #-}
peek pptr
newSymbol SymBIND pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (5)
{-# LINE 838 "PGF2/Internal.hsc" #-}
(fromIntegral ((0)))
{-# LINE 839 "PGF2/Internal.hsc" #-}
(1)
{-# LINE 840 "PGF2/Internal.hsc" #-}
pptr pool
peek pptr
newSymbol SymNE pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (7)
{-# LINE 844 "PGF2/Internal.hsc" #-}
(fromIntegral ((0)))
{-# LINE 845 "PGF2/Internal.hsc" #-}
(1)
{-# LINE 846 "PGF2/Internal.hsc" #-}
pptr pool
peek pptr
newSymbol SymSOFT_BIND pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (6)
{-# LINE 850 "PGF2/Internal.hsc" #-}
(fromIntegral ((0)))
{-# LINE 851 "PGF2/Internal.hsc" #-}
(1)
{-# LINE 852 "PGF2/Internal.hsc" #-}
pptr pool
peek pptr
newSymbol SymSOFT_SPACE pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (8)
{-# LINE 856 "PGF2/Internal.hsc" #-}
(fromIntegral ((0)))
{-# LINE 857 "PGF2/Internal.hsc" #-}
(1)
{-# LINE 858 "PGF2/Internal.hsc" #-}
pptr pool
peek pptr
newSymbol SymCAPIT pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (9)
{-# LINE 862 "PGF2/Internal.hsc" #-}
(fromIntegral ((0)))
{-# LINE 863 "PGF2/Internal.hsc" #-}
(1)
{-# LINE 864 "PGF2/Internal.hsc" #-}
pptr pool
peek pptr
newSymbol SymALL_CAPIT pool = alloca $ \pptr -> do
ptr <- gu_alloc_variant (10)
{-# LINE 868 "PGF2/Internal.hsc" #-}
(fromIntegral ((0)))
{-# LINE 869 "PGF2/Internal.hsc" #-}
(1)
{-# LINE 870 "PGF2/Internal.hsc" #-}
pptr pool
peek pptr
newSymbols syms pool = newSequence ((8)) pokeSymbol syms pool
{-# LINE 874 "PGF2/Internal.hsc" #-}
where
pokeSymbol p_sym sym = do
c_sym <- newSymbol sym pool
poke p_sym c_sym
pokeAlternatives ptr [] pool = return ()
pokeAlternatives ptr ((syms,prefixes):alts) pool = do
c_syms <- newSymbols syms pool
c_prefixes <- newSequence ((8)) (pokeString pool) prefixes pool
{-# LINE 883 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr c_syms
{-# LINE 884 "PGF2/Internal.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr c_prefixes
{-# LINE 885 "PGF2/Internal.hsc" #-}
pokeAlternatives (ptr `plusPtr` ((16))) alts pool
{-# LINE 886 "PGF2/Internal.hsc" #-}
pokeString pool c_elem str = do
c_str <- newUtf8CString str pool
poke c_elem c_str
newMap key_size hasher newKey elem_size pokeElem values pool = do
map <- gu_make_map key_size hasher
elem_size gu_null_struct
(11)
{-# LINE 895 "PGF2/Internal.hsc" #-}
pool
insert map values pool
return map
where
insert map [] pool = return ()
insert map ((key,elem):values) pool = do
c_key <- newKey key pool
c_elem <- gu_map_insert map c_key
pokeElem c_elem elem
insert map values pool
writePGF :: FilePath -> PGF -> IO ()
writePGF fpath p = do
pool <- gu_new_pool
exn <- gu_new_exn pool
withCString fpath $ \c_fpath ->
pgf_write (pgf p) c_fpath exn
touchPGF p
failed <- gu_exn_is_raised exn
if failed
then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno
if is_errno
then do perrno <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) exn
{-# LINE 919 "PGF2/Internal.hsc" #-}
errno <- peek perrno
gu_pool_free pool
ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath))
else do gu_pool_free pool
throwIO (PGFError "The grammar cannot be stored")
else do gu_pool_free pool
return ()
sortByFst = sortBy (\(x,_) (y,_) -> compare x y)
sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y)
sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y)