PMCFG pretty printer

2 files changed, 93 insertions, 54 deletions

diff --git a/src/PGF/Data.hs b/src/PGF/Data.hs
index 047b5ec46..5aba8cdfa 100644
--- a/src/PGF/Data.hs
+++ b/src/PGF/Data.hs
@@ -1,15 +1,14 @@
-module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where
+module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where
 
 import PGF.CId
 import PGF.Expr hiding (Value, Env)
 import PGF.Type
+import PGF.PMCFG
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.IntMap as IntMap
 import Data.List
-import Data.Array
-import Data.Array.Unboxed
 
 -- internal datatypes for PGF
 
@@ -54,59 +53,8 @@ data Term =
  | TM String
   deriving (Eq,Ord,Show)
 
-data Tokn =
-   KS String
- | KP [String] [Alternative]
-  deriving (Eq,Ord,Show)
-
-data Alternative =
-   Alt [String] [String]
-  deriving (Eq,Ord,Show)
-
-
-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 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)
-
 
--- print statistics
 
-statGFCC :: PGF -> String
-statGFCC pgf = unlines [
-  "Abstract\t" ++ prCId (absname pgf), 
-  "Concretes\t" ++ unwords (map prCId (cncnames pgf)), 
-  "Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract pgf)))) 
-  ]
 
 -- merge two GFCCs; fails is differens absnames; priority to second arg
 
diff --git a/src/PGF/PMCFG.hs b/src/PGF/PMCFG.hs
new file mode 100644
index 000000000..83bcc0752
--- /dev/null
+++ b/src/PGF/PMCFG.hs
@@ -0,0 +1,91 @@
+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