fix the tabular printing when there is a V constructor

3 files changed, 45 insertions, 35 deletions

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