now the pretty printer in GF has a new mode called Internal. This is the most detailed mode and it can print even things that are not in the GF syntax. For example PMCFG snippets and indirections.

src/compiler/GF/Compile.hs

@@ -147,7 +147,7 @@ compileOne opts env@(_,srcgr,_) file = do
        sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (decodeFile file)
        let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts})
 
-       intermOut opts DumpSource (ppModule Qualified sm0)
+       intermOut opts DumpSource (ppModule Internal sm0)
 
        let sm1 = unsubexpModule sm0
        (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1
@@ -172,7 +172,7 @@ compileOne opts env@(_,srcgr,_) file = do
        enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00))))
        let sm = decodeStringsInModule enc sm00
 
-       intermOut opts DumpSource (ppModule Qualified sm)
+       intermOut opts DumpSource (ppModule Internal sm)
 
        compileSourceModule opts env (Just file) sm
   where
@@ -185,11 +185,11 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
       
   (mo1,warnings)   <- ioeErr $ runCheck $ rebuildModule gr mo
   warnOut opts warnings
-  intermOut opts DumpRebuild (ppModule Qualified mo1)
+  intermOut opts DumpRebuild (ppModule Internal mo1)
 
   (mo1b,warnings)  <- ioeErr $ runCheck $ extendModule gr mo1
   warnOut opts warnings
-  intermOut opts DumpExtend (ppModule Qualified mo1b)
+  intermOut opts DumpExtend (ppModule Internal mo1b)
 
   case mo1b of
     (_,n) | not (isCompleteModule n) ->
@@ -208,23 +208,23 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
 
       (mo2,warnings) <- putpp "  renaming " $ ioeErr $ runCheck (renameModule mos mo1b)
       warnOut opts warnings
-      intermOut opts DumpRename (ppModule Qualified mo2)
+      intermOut opts DumpRename (ppModule Internal mo2)
 
       (mo3,warnings) <- putpp "  type checking" $ ioeErr $ runCheck (checkModule mos mo2)
       warnOut opts warnings
-      intermOut opts DumpTypeCheck (ppModule Qualified mo3)
+      intermOut opts DumpTypeCheck (ppModule Internal mo3)
 
       if not (flag optTagsOnly opts)
         then do (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
-                intermOut opts DumpRefresh (ppModule Qualified mo3r)
+                intermOut opts DumpRefresh (ppModule Internal mo3r)
 
                 mo4 <- putpp "  optimizing " $ ioeErr $ optimizeModule opts mos mo3r
-                intermOut opts DumpOptimize (ppModule Qualified mo4)
+                intermOut opts DumpOptimize (ppModule Internal mo4)
 
                 mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
                          then putpp "  generating PMCFG " $ ioeIO $ generatePMCFG opts mos mo4
                          else return mo4
-                intermOut opts DumpCanon (ppModule Qualified mo5)
+                intermOut opts DumpCanon (ppModule Internal mo5)
 
                 let mb_gfo = fmap (gf2gfo opts) mb_gfFile
                 case mb_gfo of

src/compiler/GF/Grammar/Printer.hs

@@ -36,7 +36,9 @@ import qualified Data.IntMap as IntMap
 import qualified Data.Set as Set
 import qualified Data.Array.IArray as Array
 
-data TermPrintQual = Qualified | Unqualified
+data TermPrintQual 
+  = Unqualified | Qualified | Internal
+  deriving Eq                 
 
 ppGrammar :: SourceGrammar -> Doc
 ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
@@ -46,7 +48,7 @@ ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
     hdr $$ 
     nest 2 (ppOptions opts $$ 
             vcat (map (ppJudgement q) (Map.toList jments)) $$
-            maybe empty ppSequences mseqs) $$
+            maybe empty (ppSequences q) mseqs) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> equals <+> 
@@ -125,8 +127,8 @@ ppJudgement q (id, CncCat  ptype pexp pprn mpmcfg) =
   (case pprn of
      Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
      Nothing        -> empty) $$
-  (case mpmcfg of
+  (case (mpmcfg,q) of
-     Just (PMCFG prods funs)
+     (Just (PMCFG prods funs),Internal)
                     -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
                        nest 2 (vcat (map ppProduction prods) $$
                                space $$
@@ -134,7 +136,7 @@ ppJudgement q (id, CncCat  ptype pexp pprn mpmcfg) =
                                                           parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
                                          (Array.assocs funs))) $$
                        char '}'
-     Nothing        -> empty)
+     _              -> empty)
 ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
   (case pdef of
      Just (L _ e) -> let (xs,e') = getAbs e
@@ -143,8 +145,8 @@ ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
   (case pprn of
      Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
      Nothing        -> empty) $$
-  (case mpmcfg of
+  (case (mpmcfg,q) of
-     Just (PMCFG prods funs)
+     (Just (PMCFG prods funs),Internal)
                     -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
                        nest 2 (vcat (map ppProduction prods) $$
                                space $$
@@ -152,8 +154,11 @@ ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
                                                           parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
                                          (Array.assocs funs))) $$
                        char '}'
-     Nothing        -> empty)
+     _              -> empty)
-ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
+ppJudgement q (id, AnyInd cann mid) =
+  case q of
+    Internal -> text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
+    _        -> empty
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
                            in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')
@@ -276,8 +281,10 @@ ppDDecl q (_,id,typ)
 
 ppQIdent q (m,id) =
   case q of
-    Qualified   -> ppIdent m <> char '.' <> ppIdent id
     Unqualified ->                          ppIdent id
+    Qualified   -> ppIdent m <> char '.' <> ppIdent id
+    Internal    -> ppIdent m <> char '.' <> ppIdent id
+    
 
 ppLabel = ppIdent . label2ident
 
@@ -308,11 +315,11 @@ ppProduction (Production fid funid args) =
   ppFId fid <+> text "->" <+> ppFunId funid <> 
   brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))
 
-ppSequences seqsArr
+ppSequences q seqsArr
-  | null seqs = empty
+  | null seqs || q /= Internal = empty
-  | otherwise = text "sequences" <+> char '{' $$
+  | otherwise                  = text "sequences" <+> char '{' $$
-                nest 2 (vcat (map ppSeq seqs)) $$
+                                 nest 2 (vcat (map ppSeq seqs)) $$
-                char '}'
+                                 char '}'
   where
     seqs = Array.assocs seqsArr