mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-19 17:59:32 -06:00
92 lines
2.8 KiB
Haskell
92 lines
2.8 KiB
Haskell
module PGF.PMCFG where
|
|
|
|
import PGF.CId
|
|
import PGF.Expr
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Data.IntMap as IntMap
|
|
import Data.Array.IArray
|
|
import Data.Array.Unboxed
|
|
import Text.PrettyPrint
|
|
|
|
type FCat = Int
|
|
type FIndex = Int
|
|
type FPointPos = Int
|
|
data FSymbol
|
|
= FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
|
|
| FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
|
|
| FSymTok Tokn
|
|
deriving (Eq,Ord,Show)
|
|
type Profile = [Int]
|
|
data Production
|
|
= FApply {-# UNPACK #-} !FunId [FCat]
|
|
| FCoerce {-# UNPACK #-} !FCat
|
|
| FConst Tree String
|
|
deriving (Eq,Ord,Show)
|
|
data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
|
|
type FSeq = Array FPointPos FSymbol
|
|
type FunId = Int
|
|
type SeqId = Int
|
|
|
|
data Tokn =
|
|
KS String
|
|
| KP [String] [Alternative]
|
|
deriving (Eq,Ord,Show)
|
|
|
|
data Alternative =
|
|
Alt [String] [String]
|
|
deriving (Eq,Ord,Show)
|
|
|
|
data ParserInfo
|
|
= ParserInfo { functions :: Array FunId FFun
|
|
, sequences :: Array SeqId FSeq
|
|
, productions :: IntMap.IntMap (Set.Set Production)
|
|
, startCats :: Map.Map CId [FCat]
|
|
, totalCats :: {-# UNPACK #-} !FCat
|
|
}
|
|
|
|
|
|
fcatString, fcatInt, fcatFloat, fcatVar :: Int
|
|
fcatString = (-1)
|
|
fcatInt = (-2)
|
|
fcatFloat = (-3)
|
|
fcatVar = (-4)
|
|
|
|
|
|
ppPMCFG :: ParserInfo -> Doc
|
|
ppPMCFG pinfo =
|
|
text "productions" $$
|
|
nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions pinfo), prod <- Set.toList set]) $$
|
|
text "functions" $$
|
|
nest 2 (vcat (map ppFun (assocs (functions pinfo)))) $$
|
|
text "sequences" $$
|
|
nest 2 (vcat (map ppSeq (assocs (sequences pinfo)))) $$
|
|
text "startcats" $$
|
|
nest 2 (vcat (map ppStartCat (Map.toList (startCats pinfo))))
|
|
|
|
ppProduction (fcat,FApply funid args) =
|
|
ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args)))
|
|
ppProduction (fcat,FCoerce arg) =
|
|
ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg)
|
|
ppProduction (fcat,FConst _ s) =
|
|
ppFCat fcat <+> text "->" <+> text (show s)
|
|
|
|
ppFun (funid,FFun fun _ arr) =
|
|
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr))))
|
|
|
|
ppSeq (seqid,seq) =
|
|
ppSeqId seqid <+> text ":=" <+> parens (hsep (map ppSymbol (elems seq)))
|
|
|
|
ppStartCat (id,fcats) =
|
|
text (prCId id) <+> text ":=" <+> brackets (hcat (punctuate comma (map ppFCat fcats)))
|
|
|
|
ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
|
|
ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
|
|
ppSymbol (FSymTok t) = text (show t)
|
|
|
|
|
|
ppFCat fcat = char 'C' <> int fcat
|
|
ppFunId funid = char 'F' <> int funid
|
|
ppSeqId seqid = char 'S' <> int seqid
|