summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler/GF/Compile.hs18
-rw-r--r--src/compiler/GF/Grammar/Printer.hs37
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:17:36 +0000