PMCFG pretty printer

GF.cabal

@@ -575,6 +575,7 @@ library
     PGF.Parsing.FCFG
     PGF.Expr
     PGF.Type
+    PGF.PMCFG
     PGF.AbsCompute
     PGF.Paraphrase
     PGF.TypeCheck
@@ -689,6 +690,7 @@ executable gf
     PGF.Data
     PGF.Expr
     PGF.Type
+    PGF.PMCFG
     PGF.Macros
     PGF.Generate
     PGF.Linearize

src/GF/Command/Commands.hs

@@ -17,7 +17,7 @@ import PGF.Data ----
 import PGF.Morphology
 import PGF.VisualizeTree
 import GF.Compile.Export
-import GF.Infra.Option (noOptions)
+import GF.Infra.Option (noOptions, readOutputFormat)
 import GF.Infra.UseIO
 import GF.Data.ErrM ----
 import PGF.Expr (readTree)
@@ -376,7 +376,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
        "N.B.2 This command is slightly obsolete: to produce different formats",
        "the batch compiler gfc is recommended, and has many more options."
        ],
-     exec  = \opts _ -> return $ fromString $ prGrammar opts,
+     exec  = \opts _ -> prGrammar opts,
      flags = [
        --"cat",
        ("lang",   "select languages for the some options (default all languages)"),
@@ -651,15 +651,13 @@ allCommands cod env@(pgf, mos) = Map.fromList [
      [] -> (ts, "no trees found")
      _ -> fromTrees ts
 
-   prGrammar opts = case opts of
+   prGrammar opts
-     _ | isOpt "cats" opts -> unwords $ map showType $ categories pgf
+     | isOpt "cats"     opts = return $ fromString $ unwords $ map showType $ categories pgf
-     _ | isOpt "fullform" opts -> concatMap 
+     | isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . morpho) $ optLangs opts
-          (prFullFormLexicon . morpho) $ optLangs opts
+     | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (prCId la:":": map prCId cs) | 
-     _ | isOpt "missing" opts -> 
-           unlines $ [unwords (prCId la:":": map prCId cs) | 
                                                                   la <- optLangs opts, let cs = missingLins pgf la]
-     _ -> case valStrOpts "printer" "pgf" opts of
+     | otherwise             = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
-       v -> concatMap snd $ exportPGF noOptions (read v) pgf
+                                  return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
 
    morphos opts s = 
      [lookupMorpho (morpho la) s | la <- optLangs opts]

src/GF/Compile/Export.hs

@@ -30,6 +30,7 @@ exportPGF :: Options
 exportPGF opts fmt pgf = 
     case fmt of
       FmtPGFPretty    -> multi "txt" prPGFPretty
+      FmtPMCFGPretty  -> single "pmcfg" prPMCFGPretty
       FmtJavaScript   -> multi "js"  pgf2js
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
       FmtProlog       -> multi "pl"  grammar2prolog 

src/GF/Compile/PGFPretty.hs

@@ -1,10 +1,11 @@
 -- | Print a part of a PGF grammar on the human-readable format used in 
 -- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
-module GF.Compile.PGFPretty (prPGFPretty) where
+module GF.Compile.PGFPretty (prPGFPretty, prPMCFGPretty) where
 
 import PGF.CId
 import PGF.Data
 import PGF.Macros
+import PGF.PMCFG
 
 import GF.Data.Operations
 
@@ -16,6 +17,13 @@ import Text.PrettyPrint.HughesPJ
 prPGFPretty :: PGF -> String
 prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf)
 
+prPMCFGPretty :: PGF -> CId -> String
+prPMCFGPretty pgf lang = render $
+  case lookParser pgf lang of
+    Nothing    -> empty
+    Just pinfo -> text "language" <+> text (prCId lang) $$ ppPMCFG pinfo
+                                                   
+
 prAbs :: Abstr -> Doc
 prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a)
 

src/GF/Infra/Option.hs

@@ -16,7 +16,7 @@ module GF.Infra.Option
      modifyFlags,
      helpMessage,
      -- * Checking specific options
-     flag, cfgTransform, haskellOption,
+     flag, cfgTransform, haskellOption, readOutputFormat,
      isLexicalCat,
      -- * Setting specific options
      setOptimization, setCFGTransform,
@@ -81,6 +81,7 @@ data Encoding = UTF_8 | ISO_8859_1 | CP_1251
   deriving (Eq,Ord)
 
 data OutputFormat = FmtPGFPretty
+                  | FmtPMCFGPretty
                   | FmtJavaScript 
                   | FmtHaskell 
                   | FmtProlog
@@ -427,7 +428,8 @@ optDescr =
 
 outputFormats :: [(String,OutputFormat)]
 outputFormats = 
-    [("pgf-pretty",   FmtPGFPretty),
+    [("pgf_pretty",   FmtPGFPretty),
+     ("pmcfg_pretty", FmtPMCFGPretty),
      ("js",           FmtJavaScript),
      ("haskell",      FmtHaskell),
      ("prolog",       FmtProlog),

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
 

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