forked from GitHub/gf-core
164 lines
6.1 KiB
Haskell
164 lines
6.1 KiB
Haskell
{-# LANGUAGE ImplicitParams #-}
|
|
module PGF.Internal(CId(..),Language,PGF2.PGF,
|
|
PGF2.Concr,lookConcr,
|
|
PGF2.FId,isPredefFId,
|
|
PGF2.FunId,PGF2.SeqId,PGF2.LIndex,PGF2.Token,
|
|
PGF2.Production(..),PGF2.PArg(..),PGF2.Symbol(..),PGF2.Literal(..),PGF2.BindType(..),Sequence,
|
|
globalFlags, abstrFlags, concrFlags,
|
|
concrTotalCats, concrCategories, concrProductions,
|
|
concrTotalFuns, concrFunction,
|
|
concrTotalSeqs, concrSequence,
|
|
|
|
PGF2.CodeLabel, PGF2.Instr(..), PGF2.IVal(..), PGF2.TailInfo(..),
|
|
|
|
PGF2.Builder, PGF2.B, PGF2.build,
|
|
eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo,
|
|
PGF2.AbstrInfo, newAbstr, PGF2.ConcrInfo, newConcr, newPGF,
|
|
|
|
-- * Write an in-memory PGF to a file
|
|
writePGF, writeConcr,
|
|
|
|
PGF2.fidString, PGF2.fidInt, PGF2.fidFloat, PGF2.fidVar, PGF2.fidStart,
|
|
|
|
ppFunId, ppSeqId, ppFId, ppMeta, ppLit, ppSeq,
|
|
|
|
unionPGF
|
|
) where
|
|
|
|
import qualified PGF2
|
|
import qualified PGF2.Internal as PGF2
|
|
import qualified Data.Map as Map
|
|
import PGF2.FFI(PGF(..))
|
|
import Data.Array.IArray
|
|
import Data.Array.Unboxed
|
|
import Text.PrettyPrint
|
|
|
|
newtype CId = CId String deriving (Show,Read,Eq,Ord)
|
|
|
|
type Language = CId
|
|
|
|
lookConcr (PGF _ langs _) (CId lang) =
|
|
case Map.lookup lang langs of
|
|
Just cnc -> cnc
|
|
Nothing -> error "Unknown language"
|
|
|
|
globalFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.globalFlags pgf]
|
|
abstrFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.abstrFlags pgf]
|
|
concrFlags concr = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.concrFlags concr]
|
|
|
|
concrTotalCats = PGF2.concrTotalCats
|
|
|
|
concrCategories :: PGF2.Concr -> [(CId,PGF2.FId,PGF2.FId,[String])]
|
|
concrCategories c = [(CId cat,start,end,lbls) | (cat,start,end,lbls) <- PGF2.concrCategories c]
|
|
|
|
concrProductions :: PGF2.Concr -> PGF2.FId -> [PGF2.Production]
|
|
concrProductions = PGF2.concrProductions
|
|
|
|
concrTotalFuns = PGF2.concrTotalFuns
|
|
|
|
concrFunction :: PGF2.Concr -> PGF2.FunId -> (CId,[PGF2.SeqId])
|
|
concrFunction c funid =
|
|
let (fun,seqids) = PGF2.concrFunction c funid
|
|
in (CId fun,seqids)
|
|
|
|
concrTotalSeqs :: PGF2.Concr -> PGF2.SeqId
|
|
concrTotalSeqs = PGF2.concrTotalSeqs
|
|
|
|
concrSequence = PGF2.concrSequence
|
|
|
|
isPredefFId = PGF2.isPredefFId
|
|
|
|
type Sequence = [PGF2.Symbol]
|
|
|
|
eAbs :: (?builder :: PGF2.Builder s) => PGF2.BindType -> CId -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
|
|
eAbs bind_type (CId var) body = PGF2.eAbs bind_type var body
|
|
|
|
eApp :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
|
|
eApp = PGF2.eApp
|
|
|
|
eMeta :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
|
|
eMeta = PGF2.eMeta
|
|
|
|
eFun (CId fun) = PGF2.eFun fun
|
|
|
|
eVar :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
|
|
eVar = PGF2.eVar
|
|
|
|
eLit :: (?builder :: PGF2.Builder s) => PGF2.Literal -> PGF2.B s PGF2.Expr
|
|
eLit = PGF2.eLit
|
|
|
|
eTyped :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Type -> PGF2.B s PGF2.Expr
|
|
eTyped = PGF2.eTyped
|
|
|
|
eImplArg :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
|
|
eImplArg = PGF2.eImplArg
|
|
|
|
dTyp :: (?builder :: PGF2.Builder s) => [PGF2.B s (PGF2.BindType,String,PGF2.Type)] -> CId -> [PGF2.B s PGF2.Expr] -> PGF2.B s PGF2.Type
|
|
dTyp hypos (CId cat) es = PGF2.dTyp hypos cat es
|
|
|
|
hypo bind_type (CId var) ty = PGF2.hypo bind_type var ty
|
|
|
|
newAbstr flags cats funs = PGF2.newAbstr [(flag,lit) | (CId flag,lit) <- flags]
|
|
[(cat,hypos,prob) | (CId cat,hypos,prob) <- cats]
|
|
[(fun,ty,arity,prob) | (CId fun,ty,arity,prob) <- funs]
|
|
|
|
newConcr abs flags printnames lindefs linrefs prods cncfuns seqs cnccats total_ccats =
|
|
PGF2.newConcr abs [(flag,lit) | (CId flag,lit) <- flags]
|
|
[(id,name) | (CId id,name) <- printnames]
|
|
lindefs linrefs
|
|
prods
|
|
[(fun,seq_ids) | (CId fun,seq_ids) <- cncfuns]
|
|
seqs
|
|
[(cat,start,end,labels) | (CId cat,start,end,labels) <- cnccats]
|
|
total_ccats
|
|
|
|
newPGF flags (CId name) abstr concrs =
|
|
PGF2.newPGF [(flag,lit) | (CId flag,lit) <- flags]
|
|
name
|
|
abstr
|
|
[(name,concr) | (CId name,concr) <- concrs]
|
|
|
|
writePGF = PGF2.writePGF
|
|
writeConcr fpath pgf lang = PGF2.writeConcr fpath (lookConcr pgf lang)
|
|
|
|
|
|
ppFunId funid = char 'F' <> int funid
|
|
ppSeqId seqid = char 'S' <> int seqid
|
|
|
|
ppFId fid
|
|
| fid == PGF2.fidString = text "CString"
|
|
| fid == PGF2.fidInt = text "CInt"
|
|
| fid == PGF2.fidFloat = text "CFloat"
|
|
| fid == PGF2.fidVar = text "CVar"
|
|
| fid == PGF2.fidStart = text "CStart"
|
|
| otherwise = char 'C' <> int fid
|
|
|
|
ppMeta :: Int -> Doc
|
|
ppMeta n
|
|
| n == 0 = char '?'
|
|
| otherwise = char '?' <> int n
|
|
|
|
ppLit (PGF2.LStr s) = text (show s)
|
|
ppLit (PGF2.LInt n) = int n
|
|
ppLit (PGF2.LFlt d) = double d
|
|
|
|
ppSeq (seqid,seq) =
|
|
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol seq)
|
|
|
|
ppSymbol (PGF2.SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
|
|
ppSymbol (PGF2.SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
|
|
ppSymbol (PGF2.SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
|
|
ppSymbol (PGF2.SymKS t) = doubleQuotes (text t)
|
|
ppSymbol PGF2.SymNE = text "nonExist"
|
|
ppSymbol PGF2.SymBIND = text "BIND"
|
|
ppSymbol PGF2.SymSOFT_BIND = text "SOFT_BIND"
|
|
ppSymbol PGF2.SymSOFT_SPACE= text "SOFT_SPACE"
|
|
ppSymbol PGF2.SymCAPIT = text "CAPIT"
|
|
ppSymbol PGF2.SymALL_CAPIT = text "ALL_CAPIT"
|
|
ppSymbol (PGF2.SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
|
|
|
|
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
|
|
|
|
unionPGF = PGF2.unionPGF
|
|
|