From b90e56a94e335d42dd5abe653555cc0854803037 Mon Sep 17 00:00:00 2001 From: krasimir Date: Wed, 3 Feb 2010 17:33:55 +0000 Subject: [PATCH] fix the tabular printing when there is a V constructor --- GF.cabal | 1 + src/compiler/GF/Grammar/Printer.hs | 37 +++----------------------- src/compiler/GF/Grammar/ShowTerm.hs | 40 +++++++++++++++++++++++++++++ src/compiler/GFI.hs | 3 ++- 4 files changed, 46 insertions(+), 35 deletions(-) create mode 100644 src/compiler/GF/Grammar/ShowTerm.hs diff --git a/GF.cabal b/GF.cabal index 6c7df6063..85b179139 100644 --- a/GF.cabal +++ b/GF.cabal @@ -119,6 +119,7 @@ executable gf GF.Grammar.Unify GF.Grammar.PatternMatch GF.Grammar.Printer + GF.Grammar.ShowTerm GF.Grammar.Binary GF.Infra.CheckM GF.Compile.Update diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 996a7a807..befc61932 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -13,12 +13,9 @@ module GF.Grammar.Printer , ppModule , ppJudgement , ppTerm - , ppTermTabular , ppPatt , ppValue , ppConstrs - - , showTerm, TermPrintStyle(..) ) where import GF.Infra.Ident @@ -26,11 +23,11 @@ import GF.Infra.Modules import GF.Infra.Option import GF.Grammar.Values import GF.Grammar.Grammar -import GF.Data.Operations -import Text.PrettyPrint +import Text.PrettyPrint import Data.Maybe (maybe) import Data.List (intersperse) +import qualified Data.Map as Map data TermPrintQual = Qualified | Unqualified @@ -38,7 +35,7 @@ ppModule :: TermPrintQual -> SourceModule -> Doc ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) = hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr where - defs = tree2list jments + defs = Map.toList jments hdr = complModDoc <+> modTypeDoc <+> equals <+> hsep (intersperse (text "**") $ @@ -187,22 +184,6 @@ ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+> ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs])) ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>' -ppTermTabular :: TermPrintQual -> Term -> [(Doc,Doc)] -ppTermTabular q = pr where - pr t = case t of - R rs -> - [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val] - T _ cs -> - [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val] - V _ cs -> - [(char '#' <> int i <+> text "=>" <+> path, str) | (i, val ) <- zip [0..] cs, (path,str) <- pr val] - _ -> [(empty,ps t)] - ps t = case t of - K s -> text s - C s u -> ps s <+> ps u - FV ts -> hsep (intersperse (char '/') (map ps ts)) - _ -> ppTerm q 0 t - ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e @@ -300,15 +281,3 @@ getLet :: Term -> ([LocalDef], Term) getLet (Let l e) = let (ls,e') = getLet e in (l:ls,e') getLet e = ([],e) - -showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String -showTerm style q t = render $ - case style of - TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t] - TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t] - TermPrintDefault -> ppTerm q 0 t - -data TermPrintStyle - = TermPrintTable - | TermPrintAll - | TermPrintDefault diff --git a/src/compiler/GF/Grammar/ShowTerm.hs b/src/compiler/GF/Grammar/ShowTerm.hs new file mode 100644 index 000000000..e039aea79 --- /dev/null +++ b/src/compiler/GF/Grammar/ShowTerm.hs @@ -0,0 +1,40 @@ +module GF.Grammar.ShowTerm where + +import GF.Grammar.Grammar +import GF.Grammar.Printer +import GF.Grammar.Lookup +import GF.Data.Operations + +import Text.PrettyPrint +import Data.List (intersperse) + +showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String +showTerm gr style q t = render $ + case style of + TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular gr q t] + TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular gr q t] + TermPrintDefault -> ppTerm q 0 t + +ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc,Doc)] +ppTermTabular gr q = pr where + pr t = case t of + R rs -> + [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val] + T _ cs -> + [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val] + V ty cs -> + let pvals = case allParamValues gr ty of + Ok pvals -> pvals + Bad _ -> map Meta [1..] + in [(ppTerm q 0 pval <+> text "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val] + _ -> [(empty,ps t)] + ps t = case t of + K s -> text s + C s u -> ps s <+> ps u + FV ts -> hsep (intersperse (char '/') (map ps ts)) + _ -> ppTerm q 0 t + +data TermPrintStyle + = TermPrintTable + | TermPrintAll + | TermPrintDefault diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index 2ea22efa6..4266afa45 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -9,6 +9,7 @@ import GF.Command.Parse import GF.Data.ErrM import GF.Grammar hiding (Ident) import GF.Grammar.Parser (runP, pExp) +import GF.Grammar.ShowTerm import GF.Compile.Rename import GF.Compile.Concrete.Compute (computeConcrete) import GF.Compile.Concrete.TypeCheck (inferLType) @@ -122,7 +123,7 @@ loop opts gfenv0 = do case runP pExp (BS.pack s) of Left (_,msg) -> putStrLn msg Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) t) of - Ok x -> putStrLn $ enc (showTerm style q x) + Ok x -> putStrLn $ enc (showTerm sgr style q x) Bad s -> putStrLn $ enc s loopNewCPU gfenv "dg":ws -> do