qualified/unqualified mode for GF.Grammar.Printer. Used in the "cc" command

5 files changed, 187 insertions, 168 deletions

diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs
index 70c36aa76..529a7b700 100644
--- a/src/GF/Compile.hs
+++ b/src/GF/Compile.hs
@@ -151,7 +151,7 @@ compileOne opts env@(_,srcgr,_) file = do
        sm00 <- putPointE Normal opts ("+ reading" +++ file) $ ioeIO (decodeFile file)
        let sm0 = addOptionsToModule opts sm00
 
-       intermOut opts DumpSource (ppModule sm0)
+       intermOut opts DumpSource (ppModule Qualified sm0)
 
        let sm1 = unsubexpModule sm0
        sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule mos sm1
@@ -171,7 +171,7 @@ compileOne opts env@(_,srcgr,_) file = do
                                            getSourceModule opts file
        let sm0 = decodeStringsInModule sm00
 
-       intermOut opts DumpSource (ppModule sm0)
+       intermOut opts DumpSource (ppModule Qualified sm0)
 
        (k',sm)  <- compileSourceModule opts env sm0
        let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str
@@ -189,28 +189,28 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
       mos   = modules gr
 
   mo1   <- ioeErr $ rebuildModule mos mo
-  intermOut opts DumpRebuild (ppModule mo1)
+  intermOut opts DumpRebuild (ppModule Qualified mo1)
 
   mo1b  <- ioeErr $ extendModule mos mo1
-  intermOut opts DumpExtend (ppModule mo1b)
+  intermOut opts DumpExtend (ppModule Qualified mo1b)
 
   case mo1b of
     (_,n) | not (isCompleteModule n) -> do
       return (k,mo1b)   -- refresh would fail, since not renamed
     _ -> do
       mo2:_ <- putpp "  renaming " $ ioeErr $ renameModule mos mo1b
-      intermOut opts DumpRename (ppModule mo2)
+      intermOut opts DumpRename (ppModule Qualified mo2)
 
       (mo3:_,warnings) <- putpp "  type checking" $ ioeErr $ showCheckModule mos mo2
       if null warnings then return () else putp warnings $ return ()
-      intermOut opts DumpTypeCheck (ppModule mo3)
+      intermOut opts DumpTypeCheck (ppModule Qualified mo3)
 
       (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
-      intermOut opts DumpRefresh (ppModule mo3r)
+      intermOut opts DumpRefresh (ppModule Qualified mo3r)
 
       let eenv = () --- emptyEEnv
       (mo4,eenv') <- putpp "  optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
-      intermOut opts DumpOptimize (ppModule mo4)
+      intermOut opts DumpOptimize (ppModule Qualified mo4)
 
       return (k',mo4)
 
diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
index 4bcea0db2..ba0f383a8 100644
--- a/src/GF/Compile/Update.hs
+++ b/src/GF/Compile/Update.hs
@@ -37,9 +37,9 @@ buildAnyTree m = go Map.empty
         Just i  -> case unifyAnyInfo c i j of
 		     Ok k  -> go (Map.insert c k map) is
 		     Bad _ -> fail $ render (text "cannot unify the informations" $$ 
-		                             nest 4 (ppJudgement (c,i)) $$
+		                             nest 4 (ppJudgement Qualified (c,i)) $$
 		                             text "and" $+$
-		                             nest 4 (ppJudgement (c,j)) $$
+		                             nest 4 (ppJudgement Qualified (c,j)) $$
 		                             text "in module" <+> ppIdent m)
         Nothing -> go (Map.insert c j map) is
 
@@ -143,9 +143,9 @@ extendMod isCompl (name,cond) base old new = foldM try new $ Map.toList old
                          Just j -> case unifyAnyInfo c i j of
 		                     Ok k  -> return $ updateTree (c,k) new
 		                     Bad _ -> fail $ render (text "cannot unify the information" $$ 
-		                                             nest 4 (ppJudgement (c,i)) $$
+		                                             nest 4 (ppJudgement Qualified (c,i)) $$
 		                                             text "in module" <+> ppIdent name <+> text "with" $$
-		                                             nest 4 (ppJudgement (c,j)) $$
+		                                             nest 4 (ppJudgement Qualified (c,j)) $$
 		                                             text "in module" <+> ppIdent base)
                          Nothing    -> if isCompl
                                          then return $ updateTree (c,indirInfo name i) new
diff --git a/src/GF/Grammar/API.hs b/src/GF/Grammar/API.hs
index 182b5e94e..76508d963 100644
--- a/src/GF/Grammar/API.hs
+++ b/src/GF/Grammar/API.hs
@@ -2,12 +2,11 @@ module GF.Grammar.API (
   Grammar,
   emptyGrammar,
   pTerm,
-  prTerm,
+  ppTerm,
   checkTerm,
   computeTerm,
   showTerm,
-  TermPrintStyle(..),
-  pTermPrintStyle
+  TermPrintStyle(..), TermPrintQual(..),
   ) where
 
 import GF.Source.ParGF
@@ -17,7 +16,7 @@ import GF.Infra.Ident
 import GF.Infra.Modules (greatestResource)
 import GF.Compile.GetGrammar
 import GF.Grammar.Macros
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 
 import GF.Compile.Rename (renameSourceTerm)
 import GF.Compile.CheckGrammar (justCheckLTerm)
@@ -27,6 +26,7 @@ import GF.Data.Operations
 import GF.Infra.Option
 
 import qualified Data.ByteString.Char8 as BS
+import Text.PrettyPrint
 
 type Grammar = SourceGrammar
 
@@ -38,9 +38,6 @@ pTerm s = do
   e <- pExp $ myLexer (BS.pack s)
   transExp e
 
-prTerm :: Term -> String
-prTerm = prt
-
 checkTerm :: Grammar -> Term -> Err Term
 checkTerm gr t = do
   mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr
@@ -54,22 +51,14 @@ checkTermAny gr m t = do
 computeTerm :: Grammar -> Term -> Err Term
 computeTerm = computeConcrete
 
-showTerm :: TermPrintStyle -> Term -> String
-showTerm style t = 
-    case style of
-      TermPrintTable   -> unlines [p +++ s | (p,s) <- prTermTabular t]
-      TermPrintAll     -> unlines [      s | (p,s) <- prTermTabular t]
-      TermPrintUnqual  -> prt_ t
-      TermPrintDefault -> prt t
-
-
-data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault
-  deriving (Show,Eq)
-
-pTermPrintStyle s = case s of
-  "table"  -> TermPrintTable
-  "all"    -> TermPrintAll
-  "unqual" -> TermPrintUnqual
-  _        -> TermPrintDefault
-
-
+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/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs
index c73e6b092..f3a19cd4b 100644
--- a/src/GF/Grammar/Printer.hs
+++ b/src/GF/Grammar/Printer.hs
@@ -8,10 +8,12 @@
 -----------------------------------------------------------------------------

 

 module GF.Grammar.Printer

-           ( ppIdent

+           ( TermPrintQual(..)

+           , ppIdent

            , ppModule

            , ppJudgement

            , ppTerm

+           , ppTermTabular

            , ppPatt

            ) where

 

@@ -25,9 +27,11 @@ import Text.PrettyPrint
 import Data.Maybe (maybe)

 import Data.List  (intersperse)

 

-ppModule :: SourceModule -> Doc

-ppModule (mn, ModInfo mtype mstat opts exts with opens _ jments _) =

-    hdr $$ nest 2 (ppOptions opts $$ vcat (map ppJudgement defs)) $$ ftr

+data TermPrintQual = Qualified | Unqualified

+

+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

 

@@ -66,153 +70,174 @@ ppOptions opts =
   text "flags" $$

   nest 2 (vcat [text option <+> equals <+> text (show value) <+> semi | (option,value) <- optionsGFO opts])

 

-ppJudgement (id, AbsCat pcont pconstrs) =

+ppJudgement q (id, AbsCat pcont pconstrs) =

   text "cat" <+> ppIdent id <+>

   (case pcont of

-     Just cont -> hsep (map ppDecl cont)

+     Just cont -> hsep (map (ppDecl q) cont)

      Nothing   -> empty) <+> semi $$

   case pconstrs of

-    Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm 0) costrs)) <+> semi

+    Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi

     Nothing     -> empty

-ppJudgement (id, AbsFun ptype pexp) =

+ppJudgement q (id, AbsFun ptype pexp) =

   (case ptype of

-     Just typ   -> text "fun" <+> ppIdent id <+> colon <+> ppTerm 0 typ <+> semi

+     Just typ   -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi

      Nothing    -> empty) $$

   (case pexp of

      Just EData -> empty

-     Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt 2) ps) <+> equals <+> ppTerm 0 e <+> semi

-     Just exp   -> text "def" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi

+     Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi

+     Just exp   -> text "def" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

      Nothing    -> empty)

-ppJudgement (id, ResParam pparams) = 

+ppJudgement q (id, ResParam pparams) = 

   text "param" <+> ppIdent id <+>

   (case pparams of

-     Just (ps,_) -> equals <+> fsep (intersperse (char '|') (map ppParam ps))

+     Just (ps,_) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))

      _           -> empty) <+> semi

-ppJudgement (id, ResValue pvalue) = empty

-ppJudgement (id, ResOper  ptype pexp) =

+ppJudgement q (id, ResValue pvalue) = empty

+ppJudgement q (id, ResOper  ptype pexp) =

   text "oper" <+> ppIdent id <+>

-  (case ptype of {Just t -> colon  <+> ppTerm 0 t; Nothing -> empty} $$

-   case pexp  of {Just e -> equals <+> ppTerm 0 e; Nothing -> empty}) <+> semi

-ppJudgement (id, ResOverload ids defs) =

+  (case ptype of {Just t -> colon  <+> ppTerm q 0 t; Nothing -> empty} $$

+   case pexp  of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi

+ppJudgement q (id, ResOverload ids defs) =

   text "oper" <+> ppIdent id <+> equals <+> 

   (text "overload" <+> lbrace $$

-   nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm 0 ty $$ equals <+> ppTerm 0 e) | (ty,e) <- defs]) $$

+   nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$

    rbrace) <+> semi

-ppJudgement (id, CncCat  ptype pexp pprn) =

+ppJudgement q (id, CncCat  ptype pexp pprn) =

   (case ptype of

-     Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm 0 typ <+> semi

+     Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi

      Nothing  -> empty) $$

   (case pexp of

-     Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi

+     Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

      Nothing  -> empty) $$

   (case pprn of

-     Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi

+     Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

      Nothing  -> empty)

-ppJudgement (id, CncFun  ptype pdef pprn) =

+ppJudgement q (id, CncFun  ptype pdef pprn) =

   (case pdef of

      Just e  -> let (vs,e') = getAbs e

-              in text "lin" <+> ppIdent id <+> hsep (map ppIdent vs) <+> equals <+> ppTerm 0 e' <+> semi

+              in text "lin" <+> ppIdent id <+> hsep (map ppIdent vs) <+> equals <+> ppTerm q 0 e' <+> semi

      Nothing -> empty) $$

   (case pprn of

-     Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi

+     Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

      Nothing  -> empty)

-ppJudgement (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid

-

-ppTerm d (Abs v e)   = let (vs,e') = getAbs e

-                       in prec d 0 (char '\\' <> commaPunct ppIdent (v:vs) <+> text "->" <+> ppTerm 0 e')

-ppTerm d (T TRaw xs) = case getCTable (T TRaw xs) of

-                         ([],_) -> text "table" <+> lbrace $$

-			           nest 2 (vcat (punctuate semi (map ppCase xs))) $$

-			           rbrace

-                         (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm 0 e)

-ppTerm d (T (TTyped t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$

-			     nest 2 (vcat (punctuate semi (map ppCase xs))) $$

-			     rbrace

-ppTerm d (T (TComp  t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$

-		 	     nest 2 (vcat (punctuate semi (map ppCase xs))) $$

-			     rbrace

-ppTerm d (T (TWild  t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$

-			     nest 2 (vcat (punctuate semi (map ppCase xs))) $$

-			     rbrace

-ppTerm d (Prod x a b)= if x == identW

-                         then prec d 0 (ppTerm 4 a <+> text "->" <+> ppTerm 0 b)

-                         else prec d 0 (parens (ppIdent x <+> colon <+> ppTerm 0 a) <+> text "->" <+> ppTerm 0 b)

-ppTerm d (Table kt vt)=prec d 0 (ppTerm 3 kt <+> text "=>" <+> ppTerm 0 vt)

-ppTerm d (Let l e)   = let (ls,e') = getLet e

-                       in prec d 0 (text "let" <+> vcat (map ppLocDef (l:ls)) $$ text "in" <+> ppTerm 0 e')

-ppTerm d (Eqs es)    = text "fn" <+> lbrace $$

-                       nest 2 (vcat (map (\e -> ppEquation e <+> semi) es)) $$

-                       rbrace

-ppTerm d (Example e s)=prec d 0 (text "in" <+> ppTerm 5 e <+> text (show s))

-ppTerm d (C e1 e2)   = prec d 1 (ppTerm 2 e1 <+> text "++" <+> ppTerm 1 e2)

-ppTerm d (Glue e1 e2)= prec d 2 (ppTerm 3 e1 <+> char '+'  <+> ppTerm 2 e2)

-ppTerm d (S x y)     = case x of

-                         T annot xs -> let e = case annot of

-			                         TTyped t -> Typed y t

-			                         TRaw     -> y

-			               in text "case" <+> ppTerm 0 e <+> text "of" <+> lbrace $$

-			                  nest 2 (vcat (punctuate semi (map ppCase xs))) $$

-			                  rbrace

-			 _          -> prec d 3 (ppTerm 3 x <+> text "!" <+> ppTerm 4 y)

-ppTerm d (ExtR x y)  = prec d 3 (ppTerm 3 x <+> text "**" <+> ppTerm 4 y)

-ppTerm d (App x y)   = prec d 4 (ppTerm 4 x <+> ppTerm 5 y)

-ppTerm d (V e es)    = text "table" <+> ppTerm 6 e <+> lbrace $$

-                       nest 2 (fsep (punctuate semi (map (ppTerm 0) es))) $$

-                       rbrace

-ppTerm d (FV es)     = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm 0) es)))

-ppTerm d (Alts (e,xs))=text "pre" <+> braces (ppTerm 0 e <> semi <+> fsep (punctuate semi (map ppAltern xs)))

-ppTerm d (Strs es)   = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm 0) es)))

-ppTerm d (EPatt p)   = prec d 4 (char '#' <+> ppPatt 2 p)

-ppTerm d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm 0 t)

-ppTerm d (P t l)     = prec d 5 (ppTerm 5 t <> char '.' <> ppLabel l)

-ppTerm d (Cn id)     = ppIdent id

-ppTerm d (Vr id)     = ppIdent id

-ppTerm d (Q  m id)   = ppIdent m <> char '.' <> ppIdent id

-ppTerm d (QC m id)   = ppIdent m <> char '.' <> ppIdent id

-ppTerm d (Sort id)   = ppIdent id

-ppTerm d (K s)       = text (show s)

-ppTerm d (EInt n)    = integer n

-ppTerm d (EFloat f)  = double f

-ppTerm d (Meta _)    = char '?'

-ppTerm d (Empty)     = text "[]"

-ppTerm d (EData)     = text "data"

-ppTerm d (R xs)      = braces (fsep (punctuate semi [ppLabel l <+> 

-                                                     fsep [case mb_t of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty},

-                                                           equals <+> ppTerm 0 e] | (l,(mb_t,e)) <- xs]))

-ppTerm d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm 0 t | (l,t) <- xs]))

-ppTerm d (Typed e t) = char '<' <> ppTerm 0 e <+> colon <+> ppTerm 0 t <> char '>'

-

-ppEquation (ps,e) = hcat (map (ppPatt 2) ps) <+> text "->" <+> ppTerm 0 e

-

-ppCase (p,e) = ppPatt 0 p <+> text "=>" <+> ppTerm 0 e

-

-ppPatt d (PAlt p1 p2) = prec d 0 (ppPatt 0 p1 <+> char '|' <+> ppPatt 1 p2)

-ppPatt d (PSeq p1 p2) = prec d 0 (ppPatt 0 p1 <+> char '+' <+> ppPatt 1 p2)

-ppPatt d (PC f ps)    = prec d 1 (ppIdent f <+> hsep (map (ppPatt 2) ps))

-ppPatt d (PP f g ps)  = prec d 1 (ppIdent f <> char '.' <> ppIdent g <+> hsep (map (ppPatt 2) ps))

-ppPatt d (PRep p)     = prec d 1 (ppPatt 2 p <> char '*')

-ppPatt d (PAs f p)    = prec d 1 (ppIdent f <> char '@' <> ppPatt 2 p)

-ppPatt d (PNeg p)     = prec d 1 (char '-' <> ppPatt 2 p)

-ppPatt d (PChar)      = char '?'

-ppPatt d (PChars s)   = brackets (text (show s))

-ppPatt d (PMacro id)  = char '#' <> ppIdent id

-ppPatt d (PM m id)    = char '#' <> ppIdent m <> char '.' <> ppIdent id

-ppPatt d (PV id)      = ppIdent id

-ppPatt d (PInt n)     = integer n

-ppPatt d (PFloat f)   = double f

-ppPatt d (PString s)  = text (show s)

-ppPatt d (PR xs)      = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt 0 e | (l,e) <- xs]))

-

-ppDecl (id,typ)

-  | id == identW = ppTerm 4 typ

-  | otherwise    = parens (ppIdent id <+> colon <+> ppTerm 0 typ)

-

-ppDDecl (id,typ)

-  | id == identW = ppTerm 6 typ

-  | otherwise    = parens (ppIdent id <+> colon <+> ppTerm 0 typ)

+ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid

+

+ppTerm q d (Abs v e)   = let (vs,e') = getAbs e

+                         in prec d 0 (char '\\' <> commaPunct ppIdent (v:vs) <+> text "->" <+> ppTerm q 0 e')

+ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of

+                           ([],_) -> text "table" <+> lbrace $$

+	  		             nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$

+			             rbrace

+                           (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e)

+ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$

+			       nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$

+			       rbrace

+ppTerm q d (T (TComp  t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$

+		 	       nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$

+			       rbrace

+ppTerm q d (T (TWild  t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$

+			       nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$

+			       rbrace

+ppTerm q d (Prod x a b)= if x == identW

+                           then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b)

+                           else prec d 0 (parens (ppIdent x <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b)

+ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)

+ppTerm q d (Let l e)    = let (ls,e') = getLet e

+                          in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')

+ppTerm q d (Eqs es)     = text "fn" <+> lbrace $$

+                          nest 2 (vcat (map (\e -> ppEquation q e <+> semi) es)) $$

+                          rbrace

+ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> text (show s))

+ppTerm q d (C e1 e2)    =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2)

+ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+'  <+> ppTerm q 2 e2)

+ppTerm q d (S x y)     = case x of

+                           T annot xs -> let e = case annot of

+			                           TTyped t -> Typed y t

+			                           TRaw     -> y

+			                 in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$

+			                    nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$

+			                   rbrace

+			   _          -> prec d 3 (ppTerm q 3 x <+> text "!" <+> ppTerm q 4 y)

+ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y)

+ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)

+ppTerm q d (V e es)    = text "table" <+> ppTerm q 6 e <+> lbrace $$

+                         nest 2 (fsep (punctuate semi (map (ppTerm q 0) es))) $$

+                         rbrace

+ppTerm q d (FV es)     = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))

+ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs)))

+ppTerm q d (Strs es)   = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))

+ppTerm q d (EPatt p)   = prec d 4 (char '#' <+> ppPatt q 2 p)

+ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t)

+ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l)

+ppTerm q d (Cn id)     = ppIdent id

+ppTerm q d (Vr id)     = ppIdent id

+ppTerm q d (Q  m id)   = ppQIdent q m id

+ppTerm q d (QC m id)   = ppQIdent q m id

+ppTerm q d (Sort id)   = ppIdent id

+ppTerm q d (K s)       = text (show s)

+ppTerm q d (EInt n)    = integer n

+ppTerm q d (EFloat f)  = double f

+ppTerm q d (Meta _)    = char '?'

+ppTerm q d (Empty)     = text "[]"

+ppTerm q d (EData)     = text "data"

+ppTerm q d (R xs)      = braces (fsep (punctuate semi [ppLabel l <+> 

+                                                       fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},

+                                                             equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))

+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

+

+ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2)

+ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)

+ppPatt q d (PC f ps)    = prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps))

+ppPatt q d (PP f g ps)  = prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 2) ps))

+ppPatt q d (PRep p)     = prec d 1 (ppPatt q 2 p <> char '*')

+ppPatt q d (PAs f p)    = prec d 1 (ppIdent f <> char '@' <> ppPatt q 2 p)

+ppPatt q d (PNeg p)     = prec d 1 (char '-' <> ppPatt q 2 p)

+ppPatt q d (PChar)      = char '?'

+ppPatt q d (PChars s)   = brackets (text (show s))

+ppPatt q d (PMacro id)  = char '#' <> ppIdent id

+ppPatt q d (PM m id)    = char '#' <> ppIdent m <> char '.' <> ppIdent id

+ppPatt q d (PV id)      = ppIdent id

+ppPatt q d (PInt n)     = integer n

+ppPatt q d (PFloat f)   = double f

+ppPatt q d (PString s)  = text (show s)

+ppPatt q d (PR xs)      = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))

+

+ppDecl q (id,typ)

+  | id == identW = ppTerm q 4 typ

+  | otherwise    = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)

+

+ppDDecl q (id,typ)

+  | id == identW = ppTerm q 6 typ

+  | otherwise    = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)

 

 ppIdent = text . prIdent

 

+ppQIdent q m id =

+  case q of

+    Qualified   -> ppIdent m <> char '.' <> ppIdent id

+    Unqualified ->                          ppIdent id

+

 ppLabel = ppIdent . label2ident

 

 ppOpenSpec (OSimple id)   = ppIdent id

@@ -220,14 +245,14 @@ ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
 

 ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)

 

-ppLocDef (id, (mbt, e)) =

+ppLocDef q (id, (mbt, e)) =

   ppIdent id <+>

-  (case mbt of {Just t -> colon  <+> ppTerm 0 t; Nothing -> empty} <+> equals <+> ppTerm 0 e) <+> semi

+  (case mbt of {Just t -> colon  <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi

 

 

-ppAltern (x,y) = ppTerm 0 x <+> char '/' <+> ppTerm 0 y

+ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y

 

-ppParam (id,cxt) = ppIdent id <+> hsep (map ppDDecl cxt)

+ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)

 

 commaPunct f ds = (hcat (punctuate comma (map f ds)))

 

diff --git a/src/GFI.hs b/src/GFI.hs
index e5926f5e9..486b807d0 100644
--- a/src/GFI.hs
+++ b/src/GFI.hs
@@ -95,12 +95,17 @@ loop opts gfenv0 = do
              system $ unwords ws
              loopNewCPU gfenv
           "cc":ws -> do
-             let 
-               (style,term) = case ws of 
-                 ('-':w):ws2 -> (pTermPrintStyle w, ws2)
-                 _ -> (TermPrintDefault, ws)
-             case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of
-               Ok  x -> putStrLn $ enc (showTerm style x)
+             let
+               pOpts style q ("-table"  :ws) = pOpts TermPrintTable   q           ws
+               pOpts style q ("-all"    :ws) = pOpts TermPrintAll     q           ws
+               pOpts style q ("-default":ws) = pOpts TermPrintDefault q           ws
+               pOpts style q ("-unqual" :ws) = pOpts style            Unqualified ws
+               pOpts style q ("-qual"   :ws) = pOpts style            Qualified   ws
+               pOpts style q             ws  = (style,q,unwords ws)
+               
+               (style,q,s) = pOpts TermPrintDefault Qualified ws
+             case pTerm s >>= checkTerm sgr >>= computeTerm sgr of
+               Ok  x -> putStrLn $ enc (showTerm style q x)
                Bad s -> putStrLn $ enc s
              loopNewCPU gfenv
           "dg":ws -> do