From 8a10aa5cf969caf482a7e852562caad815d74672 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Tue, 15 Nov 2011 15:55:45 +0000 Subject: [PATCH] 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 | 18 +++++++-------- src/compiler/GF/Grammar/Printer.hs | 37 ++++++++++++++++++------------ 2 files changed, 31 insertions(+), 24 deletions(-) diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 832f4316c..01679f727 100644 --- a/src/compiler/GF/Compile.hs +++ b/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 diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index cf0bbf6e9..fe5fe8803 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/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 - Just (PMCFG prods funs) + (case (mpmcfg,q) of + (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 - Just (PMCFG prods funs) + (case (mpmcfg,q) of + (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) -ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi + _ -> empty) +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 - | null seqs = empty - | otherwise = text "sequences" <+> char '{' $$ - nest 2 (vcat (map ppSeq seqs)) $$ - char '}' +ppSequences q seqsArr + | null seqs || q /= Internal = empty + | otherwise = text "sequences" <+> char '{' $$ + nest 2 (vcat (map ppSeq seqs)) $$ + char '}' where seqs = Array.assocs seqsArr