Use GF.Grammar.Printer everywhere instead of PrGrammar

2009-09-14 15:13:11 +00:00
parent 3e489086ed
commit 9cebd25eac
19 changed files with 189 additions and 169 deletions
--- a/src/GF/Compile/AbsCompute.hs
+++ b/src/GF/Compile/AbsCompute.hs
@@ -30,6 +30,7 @@ import GF.Compile.Compute
 import Debug.Trace
 import Data.List(intersperse)
 import Control.Monad (liftM, liftM2)
+import Text.PrettyPrint

 -- for debugging
 tracd m t = t 
@@ -45,7 +46,7 @@ computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
 type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])

 computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
-computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
+computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
  compt vv t = case t of
 --    Prod x a b  -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
 --    Abs x b     -> liftM  (Abs  x)              (compt (x:vv) b)
@@ -55,21 +56,21 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
      let vv' = yy ++ vv
      aa'    <- mapM (compt vv') aa
      case look f of
-        Just eqs -> tracd ("\nmatching" +++ prt f) $ 
+        Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $ 
                          case findMatch eqs aa' of
          Ok (d,g) -> do
            --- let (xs,ts) = unzip g
            --- ts' <- alphaFreshAll vv' ts
            let g' = g --- zip xs ts'
            d' <- compt vv' $ substTerm vv' g' d
-            tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d'
-          _ -> tracd ("no match" +++ prt t') $ 
+            tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
+          _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ 
               do
            let v = mkApp f aa'
            return $ mkAbs yy $ v
        _ -> do
          let t2 = mkAbs yy $ mkApp f aa'
-          tracd ("not defined" +++ prt_ t2) $ return t2
+          tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2

  look t = case t of
     (Q m f) -> case lookd m f of
@@ -93,12 +94,12 @@ beta vv c = case c of

 findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
 findMatch cases terms = case cases of
-  [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
+  [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
  (patts,_):_ | length patts /= length terms -> 
-       Bad ("wrong number of args for patterns :" +++ 
-            unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
+       Bad (render (text "wrong number of args for patterns :" <+> 
+                    hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
  (patts,val):cc -> case mapM tryMatch (zip patts terms) of
-     Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs)
+     Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
     _         -> findMatch cc terms

 tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
@@ -127,7 +128,7 @@ tryMatch (p,t) = do
    (PAs x p',_) -> do
       subst <- trym p' t'
       return $ (x,t) : subst
-    _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t)
+    _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))

  notMeta e = case e of
    Meta _  -> False
@@ -136,4 +137,4 @@ tryMatch (p,t) = do
    _ -> True

  prtm p g = 
-    prt p +++ ":" ++++ unwords ["  " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g]
+    ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -129,7 +129,7 @@ checkAbsInfo st m mo c info = do
 where
   mkCheck cat ss = case ss of
     [] -> return info
-     _  -> checkError (vcat (map text ss) $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c)
+     _  -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c)

   compAbsTyp g t = case t of
     Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
--- a/src/GF/Compile/Compute.hs
+++ b/src/GF/Compile/Compute.hs
@@ -18,9 +18,9 @@ import GF.Data.Operations
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Infra.Option
-import GF.Data.Str
-import GF.Grammar.PrGrammar
 import GF.Infra.Modules
+import GF.Data.Str
+import GF.Grammar.Printer
 import GF.Grammar.Predef
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
@@ -32,8 +32,7 @@ import GF.Grammar.AppPredefined

 import Data.List (nub,intersperse)
 import Control.Monad (liftM2, liftM)
-
---- import Debug.Trace ----
+import Text.PrettyPrint

 -- | computation of concrete syntax terms into normal form
 -- used mainly for partial evaluation
@@ -57,7 +56,7 @@ computeTermOpt rec gr = comput True where
           | otherwise    -> look p c 

     Vr x -> do
-       t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g
+       t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g
       case t' of 
         _ | t == t' -> return t
         _ -> comp g t'
@@ -113,7 +112,7 @@ computeTermOpt rec gr = comput True where
       t' <- comp g t
       case t' of
         FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
-         R r   -> maybe (prtBad "no value for label" l) (comp g . snd) $ 
+         R r   -> maybe (Bad (render (text "no value for label" <+> ppLabel l))) (comp g . snd) $ 
                    lookup l $ reverse r 

         ExtR a (R b) ->                 
@@ -275,7 +274,7 @@ computeTermOpt rec gr = comput True where
     compPatternMacro p = case p of
       PM m c -> case look m c of
         Ok (EPatt p') -> compPatternMacro p'
-         _ -> prtBad "pattern expected as value of" p ---- should be in CheckGr
+         _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p)))
       PAs x p -> do
         p' <- compPatternMacro p
         return $ PAs x p'
@@ -325,7 +324,7 @@ computeTermOpt rec gr = comput True where
                 _ -> v'
           case matchPattern cc v2 of
             Ok (c,g') -> comp (g' ++ g) c
-             _ | isCan v2 -> prtBad ("missing case" +++ prt v2 +++ "in") t 
+             _ | isCan v2 -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v2 <+> text "in" <+> ppTerm Unqualified 0 t))
             _ -> return $ S t' v' -- if v' is not canonical

         S (T i cs) e -> prawitz g i (flip S v') cs e
@@ -422,7 +421,7 @@ computeTermOpt rec gr = comput True where
           as <- getPatts a
           bs <- getPatts b
           return [K (s ++ t) | K s <- as, K t <- bs]
-         _ -> fail $ "not valid pattern in pre expression" +++ prt p
+         _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))

 {- ----
     uncurrySelect g fs t v = do
@@ -450,18 +449,15 @@ computeTermOpt rec gr = comput True where
 -- | argument variables cannot be glued
 checkNoArgVars :: Term -> Err Term
 checkNoArgVars t = case t of
-  Vr (IA _ _)    -> Bad $ glueErrorMsg $ prt t 
-  Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t 
+  Vr (IA _ _)    -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t 
+  Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t 
  _ -> composOp checkNoArgVars t

 glueErrorMsg s = 
-  "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
-  "Use Prelude.bind instead."
+  render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$
+          text "Use Prelude.bind instead.")

 getArgType t = case t of
  V ty _ -> return ty
  T (TComp ty) _ -> return ty
-  _ -> prtBad "cannot get argument type of table" t
-
-
-
+  _ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t)))
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -11,7 +11,7 @@ import qualified PGF.Macros as CM
 import qualified PGF.Data as C
 import qualified PGF.Data as D
 import GF.Grammar.Predef
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar.Abstract as A
@@ -28,6 +28,7 @@ import Data.List
 import Data.Char (isDigit,isSpace)
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as BS
+import Text.PrettyPrint
 import Debug.Trace ----

 -- when developing, swap commenting
@@ -60,7 +61,7 @@ addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toL

 canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
 canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = 
-  (if dump opts DumpCanon then trace (prGrammar cgr) else id) $
+  (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $
     D.PGF an cns gflags abs cncs 
 where
  -- abstract
@@ -181,7 +182,7 @@ mkTerm tr = case tr of
  Abs _ t  -> mkTerm t ---- only on toplevel
  Alts (td,tvs) -> 
    C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
-  _ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
+  _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging
 where
   mkLab (LIdent l) = case BS.unpack l of
     '_':ds -> (read ds) :: Int
@@ -218,7 +219,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
  mkPType typ = case typ of
    RecType lts -> do
      ts <- mapM (mkPType . snd) lts
-      return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
+      return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts]
    Table (RecType lts) v -> do
      ps <- mapM (mkPType . snd) lts
      v' <- mkPType v
@@ -229,7 +230,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
      return $ C.S [p',v']
    Sort s | s == cStr -> return $ C.S []
    _ -> return $ 
-      C.FV $ map (kks . filter showable . prt_) $ 
+      C.FV $ map (kks . filter showable . render . ppTerm Qualified 0) $ 
             errVal [] $ Look.allParamValues sgr typ
  showable c = not (isSpace c) ---- || (c == ' ')  -- to eliminate \n in records
  kks = C.K . C.KS
@@ -275,7 +276,7 @@ repartition abs cg =
      [] -> [abs]  -- to make pgf nonempty even when there are no concretes
      cncs -> cncs,
    let mo = errVal 
-         (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang
+         (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang
    ]

 -- translate tables and records to arrays, parameters and labels to indices
@@ -292,7 +293,7 @@ canon2canon opts abs cg0 =
  c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo))

  j2j cg (f,j) = 
-    let debug = if verbAtLeast opts Verbose then trace ("+ " ++ prt f) else id in
+    let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
    case j of
      CncFun x (Just tr) z -> CncFun x (Just (debug (t2t tr))) z
      CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t x)) y
@@ -313,23 +314,22 @@ canon2canon opts abs cg0 =
      _ -> [(x,ty)]

 ----
-  trs v = traceD (tr v) v
+  trs v = traceD (render (tr v)) v

  tr (labels,untyps,typs) =
-     ("LABELS:" ++++
-       unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i  | 
-       ((c,l),i) <- Map.toList labels]) ++++
-     ("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i | 
-       (t,i) <- Map.toList untyps]) ++++
-     ("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) | 
-       (t,i) <- Map.toList typs])
+     (text "LABELS:" <+>
+        vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i)  | ((c,l),i) <- Map.toList labels]) $$
+     (text "UNTYPS:" <+>
+        vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$
+     (text "TYPS:  " <+>
+        vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs])
 ----

 purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
 purgeGrammar abstr gr = 
  (M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr 
 where
-  list ms = traceD ("MODULES" +++ unwords (map (prt . fst) ms)) ms
+  list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms
  purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
  needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
  acncs = abstr : M.allConcretes gr abstr
@@ -384,7 +384,7 @@ paramValues cgr = (labels,untyps,typs) where
      updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
    _ -> GM.composOp typsFromTrm tr

-  mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.modules cgr
+  mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr

  jments = 
    [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo]
@@ -435,7 +435,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
  P  t l   -> r2r tr
  PI t l i -> EInt $ toInteger i

-  T (TWild _) _ -> error $ "wild" +++ prt tr
+  T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr))
  T (TComp  ty) cs  -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
  T (TTyped ty) cs  -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
  V ty ts  -> mkCurry $ V ty [t2t t | t <- ts]
@@ -468,8 +468,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
               Just vs -> (ty,[t | 
                            (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) 
                                            (Map.assocs vs)])
-               _ -> error $ "doVar1" +++ A.prt ty
-             _ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug
+               _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty)
+             _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug
       updateSTM ((tyvs, (tr', tr)):) 
       return tr'
     _ -> GM.composOp doVar tr
@@ -480,7 +480,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
     Ok (cat,labs) -> P (t2t p) . mkLab $ 
          maybe (prtTrace tr $ 66664) snd $ 
            Map.lookup (cat,labs) labels
-     _ -> K ((A.prt tr +++ prtTrace tr "66665"))
+     _ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665)))

   -- this goes recursively into tables (ignored) and records (accumulated)
   getLab tr = case tr of
@@ -511,8 +511,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
        (FV ts,_) -> ts
        _ -> [tr]
      valNumFV ts = case ts of
-        [tr] -> let msg = ("DEBUG" +++ prt fun ++ ": error in valNum" +++ prt tr) in 
-                trace msg $ error (prt fun)
+        [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in 
+                trace msg $ error (showIdent fun)
        _ -> FV $ map valNum ts

   mkCurry trm = case trm of
@@ -553,8 +553,8 @@ unlockTy ty = case ty of


 prtTrace tr n = 
-  trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n
-prTrace  tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
+  trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n
+prTrace  tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n


 -- | this function finds out what modules are really needed in the canonical gr.
--- a/src/GF/Compile/ModDeps.hs
+++ b/src/GF/Compile/ModDeps.hs
@@ -23,7 +23,7 @@ module GF.Compile.ModDeps (mkSourceGrammar,
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Infra.Option
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 import GF.Compile.Update
 import GF.Grammar.Lookup
 import GF.Infra.Modules
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -18,7 +18,7 @@ module GF.Compile.Optimize (optimizeModule) where
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Infra.Modules
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
@@ -35,15 +35,10 @@ import GF.Infra.Option
 import Control.Monad
 import Data.List
 import qualified Data.Set as Set
-
+import Text.PrettyPrint
 import Debug.Trace


-- conditional trace
-
-prtIf :: (Print a) => Bool -> a -> a
-prtIf b t = if b then trace (" " ++ prt t) t else t
-
 -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.

 type EEnv = () --- not used
@@ -81,7 +76,7 @@ evalModule oopts (ms,eenv) mo@(name,m0)
   gr  = MGrammar $ mo : ms

   evalOp g@(MGrammar ((_,m) : _)) i = do
-     info  <- lookupTree prt i $ jments m
+     info  <- lookupTree showIdent i $ jments m
     info' <- evalResInfo oopts gr (i,info)
     return $ updateRes g name i info'

@@ -97,7 +92,7 @@ updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
 evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
 evalResInfo oopts gr (c,info) = case info of

-  ResOper pty pde -> eIn "operation" $ do
+  ResOper pty pde -> eIn (text "operation") $ do
    pde' <- case pde of
              Just de | optres -> liftM Just $ comp de 
              _                -> return pde
@@ -106,7 +101,7 @@ evalResInfo oopts gr (c,info) = case info of
  _ ->  return info
 where
   comp = if optres then computeConcrete gr else computeConcreteRec gr
-   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+   eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
   optim = flag optOptimizations oopts
   optres = OptExpand `Set.member` optim

@@ -115,9 +110,9 @@ evalCncInfo ::
  Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info
 evalCncInfo opts gr cnc abs (c,info) = do

- seq (prtIf (verbAtLeast opts Verbose) c) $ return ()
+ (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()

- errIn ("optimizing" +++ prt c) $ case info of
+ errIn ("optimizing " ++ showIdent c) $ case info of

  CncCat ptyp pde ppr -> do
    pde' <- case (ptyp,pde) of
@@ -127,12 +122,12 @@ evalCncInfo opts gr cnc abs (c,info) = do
        liftM Just $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
      _ -> return pde   -- indirection

-    ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ prt c)
+    ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c)

    return (CncCat ptyp pde' ppr')

  CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $
-       eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
+       eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd (cont,val,[])) $$ text "of function") $ do
    pde' <- case pde of
      Just de -> liftM Just $ pEval ty de
      Nothing -> return pde
@@ -142,11 +137,11 @@ evalCncInfo opts gr cnc abs (c,info) = do
  _ ->  return info
 where
   pEval = partEval opts gr
-   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+   eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))

 -- | the main function for compiling linearizations
 partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
-partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
+partEval opts gr (context, val) trm = errIn (render (text "parteval" <+> ppTerm Qualified 0 trm)) $ do
  let vars  = map fst context
      args  = map Vr vars
      subst = [(v, Vr v) | v <- vars]
@@ -199,7 +194,7 @@ mkLinDefault gr typ = do
       ts' <- mapM mkDefField ts
       return $ R $ [assign l t | (l,t) <- zip ls ts']
     _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
-     _ -> prtBad "linearization type field cannot be" typ
+     _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))

 -- | Form the printname: if given, compute. If not, use the computed
 -- lin for functions, cat name for cats (dispatch made in evalCncDef above).
@@ -210,8 +205,8 @@ evalPrintname gr c ppr lin =
  case ppr of
    Just pr -> comp pr
    Nothing -> case lin of
-                 Just t  -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
-                 Nothing -> return $ K $ prt c ----
+                 Just t  -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t))
+                 Nothing -> return $ K $ showIdent c ----
 where
   comp = computeConcrete gr

--- a/src/GF/Compile/OptimizeGF.hs
+++ b/src/GF/Compile/OptimizeGF.hs
@@ -23,7 +23,6 @@ import GF.Grammar.Grammar
 import GF.Grammar.Lookup
 import GF.Infra.Ident
 import qualified GF.Grammar.Macros as C
-import GF.Grammar.PrGrammar (prt)
 import qualified GF.Infra.Modules as M
 import GF.Data.Operations

@@ -86,7 +85,7 @@ factor c i t = case t of

 --- we hope this will be fresh and don't check... in GFC would be safe

-qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i))
+qqIdent c i = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))


 --  we need to replace subterms
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -33,7 +33,7 @@ import GF.Grammar.Predef
 import GF.Infra.Modules
 import GF.Infra.Ident
 import GF.Grammar.Macros
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 import GF.Grammar.AppPredefined
 import GF.Grammar.Lookup
 import GF.Grammar.Printer
@@ -55,7 +55,7 @@ renameSourceTerm g m t = do
  renameTerm status [] t

 renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
-renameModule ms (name,mo) = errIn ("renaming module" +++ prt name) $ do
+renameModule ms (name,mo) = errIn ("renaming module" +++ showIdent name) $ do
  let js1 = jments mo
  status <- buildStatus (MGrammar ms) name mo
  js2    <- mapsErrTree (renameInfo mo status) js1
@@ -69,19 +69,19 @@ type StatusInfo = Ident -> Term

 renameIdentTerm :: Status -> Term -> Err Term
 renameIdentTerm env@(act,imps) t = 
- errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
+ errIn (render (text "atomic term" <+> ppTerm Unqualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs)))) $
   case t of
  Vr c -> ident predefAbs c
  Cn c -> ident (\_ s -> Bad s) c
  Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
  Q m' c -> do
    m <- lookupErr m' qualifs
-    f <- lookupTree prt c m
+    f <- lookupTree showIdent c m
    return $ f c
  QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
  QC m' c -> do
    m <- lookupErr m' qualifs
-    f <- lookupTree prt c m
+    f <- lookupTree showIdent c m
    return $ f c
  _ -> return t
 where
@@ -94,14 +94,14 @@ renameIdentTerm env@(act,imps) t =
     | isPredefCat c = return $ Q cPredefAbs c
     | otherwise     = Bad s

-   ident alt c = case lookupTree prt c act of
+   ident alt c = case lookupTree showIdent c act of
      Ok f -> return $ f c
-      _ -> case lookupTreeManyAll prt opens c of
+      _ -> case lookupTreeManyAll showIdent opens c of
        [f] -> return $ f c
-        []  -> alt c ("constant not found:" +++ prt c) 
+        []  -> alt c (render (text "constant not found:" <+> ppIdent c))
        fs -> case nub [f c | f <- fs]  of
          [tr] -> return tr
-          ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t)
+          ts@(t:_) -> trace (render (text "Warning: conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))) (return t)
            -- a warning will be generated in CheckGrammar, and the head returned
            -- in next V: 
            -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
@@ -152,7 +152,7 @@ forceQualif o = case o of
  
 renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info)
 renameInfo mo status (i,info) = errIn 
-    ("renaming definition of" +++ prt i +++ showPosition mo i) $ 
+    (render (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i)) $ 
                                liftM ((,) i) $ case info of
  AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
                                  (renPerh (mapM rent) pfs)
@@ -210,7 +210,7 @@ renameTerm env vars = ren vars where
          Ok t -> return t
          _ -> case liftM (flip P l) $ renid t of
            Ok t -> return t                              -- const proj last
-            _ -> prtBad "unknown qualified constant" trm
+            _ -> Bad (render (text "unknown qualified constant" <+> ppTerm Qualified 0 trm))

    EPatt p -> do
      (p',_) <- renpatt p
@@ -233,7 +233,7 @@ renamePattern env patt = case patt of
    c' <- renid $ Vr c
    case c' of
      Q p d -> renp $ PM p d
-      _ -> prtBad "unresolved pattern" patt
+      _ -> Bad (render (text "unresolved pattern" <+> ppPatt Unqualified 0 patt))

  PC c ps -> do
    c' <- renid $ Cn c
@@ -254,7 +254,7 @@ renamePattern env patt = case patt of
  PM p c -> do
    (p', c') <- case renid (Q p c) of
      Ok (Q p' c') -> return (p',c')
-      _ -> prtBad "not a pattern macro" patt
+      _ -> Bad (render (text "not a pattern macro" <+> ppPatt Unqualified 0 patt))
    return (PM p' c', [])

  PV x -> do case renid (Vr x) of
--- a/src/GF/Compile/TC.hs
+++ b/src/GF/Compile/TC.hs
@@ -58,7 +58,7 @@ lookupConst :: Theory -> QIdent -> Err Val
 lookupConst th f = th f

 lookupVar :: Env -> Ident -> Err Val
-lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g)
+lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((IW,uVal):g)
 -- wild card IW: no error produced, ?0 instead.

 type TCEnv = (Int,Env,Env)
@@ -130,7 +130,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
 	(t',cs) <- checkExp th 
                           (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
 	return (AAbs x a' t', cs)
-      _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
+      _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))

    Prod x a b -> do
      testErr (typ == vType) "expected Type"
@@ -146,7 +146,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
                          r <- mapM (checkAssign th tenv ys) xs
                          let (xs,css) = unzip r
                          return (AR xs, concat css)
-        _           -> prtBad ("record type expected for" +++ prt e +++ "instead of") typ
+        _           -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))

    P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
                return (AP r' l typ,cs)
@@ -181,8 +181,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of
        (a',csa) <- checkExp th tenv t (VClos env a)
 	b' <- whnf $ VClos ((x,VClos rho t):env) b
 	return $ (AApp f' a' b', b', csf ++ csa)
-      _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
-   _ -> prtBad "cannot infer type of expression" e
+      _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
+   _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e))

 checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
 checkLabelling th tenv (lbl,typ) = do
@@ -224,7 +224,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
          let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
          ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
 	  return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
-        _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ
+        _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ))
    [] -> do
      (e,cs) <- checkExp th tenv t ty
      return (([],e),cs)
@@ -242,7 +242,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
     PFloat n -> (EFloat n : ps, i, g, k)
     PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') 
                    where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
-     _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
+     _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")

  upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables

@@ -280,8 +280,8 @@ checkPatt th tenv exp val = do
           (a',_,csa) <- checkExpP tenv t (VClos env a)
 	   b' <- whnf $ VClos ((x,VClos rho t):env) b
 	   return $ (AApp f' a' b', b', csf ++ csa)
-         _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
-     _ -> prtBad "cannot typecheck pattern" exp
+         _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
+     _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))

 -- auxiliaries

--- a/src/GF/Compile/TypeCheck.hs
+++ b/src/GF/Compile/TypeCheck.hs
@@ -21,6 +21,7 @@ module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should n

 import GF.Data.Operations

+import GF.Infra.CheckM
 import GF.Grammar.Abstract
 import GF.Grammar.Lookup
 import GF.Grammar.Unify
@@ -29,6 +30,7 @@ import GF.Compile.Refresh
 import GF.Compile.AbsCompute
 import GF.Compile.TC

+import Text.PrettyPrint
 import Control.Monad (foldM, liftM, liftM2)

 -- | invariant way of creating TCEnv from context
@@ -65,14 +67,14 @@ grammar2theory gr (m,f) = case lookupFunType gr m f of
    Ok cont -> return $ cont2val cont
    _ -> Bad s

-checkContext :: Grammar -> Context -> [String]
+checkContext :: Grammar -> Context -> [Message]
 checkContext st = checkTyp st . cont2exp

-checkTyp :: Grammar -> Type -> [String]
-checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType
+checkTyp :: Grammar -> Type -> [Message]
+checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType

-checkDef :: Grammar -> Fun -> Type -> [Equation] -> [String]
-checkDef gr (m,fun) typ eqs = err singleton prConstrs $ do
+checkDef :: Grammar -> Fun -> Type -> [Equation] -> [Message]
+checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do
  bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
  let (bs,css) = unzip bcs
  (constrs,_) <- unifyVal (concat css)
--- a/src/GF/Grammar/Abstract.hs
+++ b/src/GF/Grammar/Abstract.hs
@@ -19,7 +19,7 @@ module GF.Grammar.Values,
 module GF.Grammar.Macros,
 module GF.Infra.Ident,
 module GF.Grammar.MMacros,
-module GF.Grammar.PrGrammar,
+module GF.Grammar.Printer,

 Grammar

@@ -30,7 +30,7 @@ import GF.Grammar.Values
 import GF.Grammar.Macros
 import GF.Infra.Ident
 import GF.Grammar.MMacros
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer

 type Grammar = SourceGrammar ---

--- a/src/GF/Grammar/AppPredefined.hs
+++ b/src/GF/Grammar/AppPredefined.hs
@@ -20,8 +20,9 @@ import GF.Data.Operations
 import GF.Grammar.Predef
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
-import GF.Grammar.PrGrammar (prt,prt_,prtBad)
+import GF.Grammar.Printer
 import qualified Data.ByteString.Char8 as BS
+import Text.PrettyPrint

 -- predefined function type signatures and definitions. AR 12/3/2003.

@@ -56,7 +57,7 @@ typPredefined f
    ([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
  | f == cTake      = return $ mkFunType [typeInt,typeTok] typeTok
  | f == cTk        = return $ mkFunType [typeInt,typeTok] typeTok
-  | otherwise       = prtBad "unknown in Predef:" f
+  | otherwise       = Bad (render (text "unknown in Predef:" <+> ppIdent f))

 varL :: Ident
 varL = identC (BS.pack "L")
@@ -89,7 +90,7 @@ appPredefined t = case t of
      (EInt i, EInt j) | f == cEqInt   -> retb $ if i==j then predefTrue else predefFalse
      (EInt i, EInt j) | f == cLessInt -> retb $ if i<j  then predefTrue else predefFalse
      (EInt i, EInt j) | f == cPlus    -> retb $ EInt $ i+j
-      (_,      t)      | f == cShow    -> retb $ foldr C Empty $ map K $ words $ prt t
+      (_,      t)      | f == cShow    -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t)
      (_,      K s)    | f == cRead    -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
      (_,      t)      | f == cToStr   -> trm2str t >>= retb
      _ -> retb t ---- prtBad "cannot compute predefined" t
@@ -137,11 +138,11 @@ trm2str t = case t of
  T _ ((_,s):_)   -> trm2str s
  TSh _ ((_,s):_) -> trm2str s
  V _ (s:_)       -> trm2str s
-  C _ _         -> return $ t
-  K _           -> return $ t
-  S c _         -> trm2str c
-  Empty         -> return $ t
-  _ -> prtBad "cannot get Str from term" t
+  C _ _           -> return $ t
+  K _             -> return $ t
+  S c _           -> trm2str c
+  Empty           -> return $ t
+  _               -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))

 -- simultaneous recursion on type and term: type arg is essential!
 -- But simplify the task by assuming records are type-annotated
--- a/src/GF/Grammar/Lockfield.hs
+++ b/src/GF/Grammar/Lockfield.hs
@@ -21,14 +21,13 @@ import qualified Data.ByteString.Char8 as BS
 import GF.Infra.Ident
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
-import GF.Grammar.PrGrammar

 import GF.Data.Operations

 lockRecType :: Ident -> Type -> Err Type
 lockRecType c t@(RecType rs) = 
  let lab = lockLabel c in
-  return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"]
+  return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
    then t --- don't add an extra copy of lock field, nor predef cats
    else RecType (rs ++ [(lockLabel c,  RecType [])])
 lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -16,20 +16,20 @@
 -----------------------------------------------------------------------------

 module GF.Grammar.Lookup (
-               lookupIdent,
-               lookupIdentInfo,
-               lookupIdentInfoIn,
-               lookupOrigInfo,
-               lookupResDef,
-               lookupResDefKind,
+           lookupIdent,
+           lookupIdentInfo,
+           lookupIdentInfoIn,
+           lookupOrigInfo,
+           lookupResDef,
+           lookupResDefKind,
 	       lookupResType, 
-               lookupOverload,
+           lookupOverload,
 	       lookupParams, 
 	       lookupParamValues, 
 	       lookupFirstTag, 
-               lookupValueIndex,
-               lookupIndexValue,
-               allOrigInfos,
+           lookupValueIndex,
+           lookupIndexValue,
+           allOrigInfos,
 	       allParamValues, 
 	       lookupAbsDef, 
 	       lookupLincat, 
@@ -39,13 +39,17 @@ module GF.Grammar.Lookup (
 	      ) where

 import GF.Data.Operations
-import GF.Grammar.Abstract
+import GF.Infra.Ident
 import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Grammar
+import GF.Grammar.Printer
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield

 import Data.List (nub,sortBy)
 import Control.Monad
+import Text.PrettyPrint

 -- whether lock fields are added in reuse
 lock c = lockRecType c -- return
@@ -92,7 +96,7 @@ lookupResDefKind gr m c
      AnyInd _ n        -> look False n c
      ResParam _        -> return (QC m c,2)
      ResValue _        -> return (QC m c,2)
-      _   -> Bad $ prt c +++ "is not defined in resource" +++ prt m
+      _   -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
  lookExt m c =
    checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])

@@ -112,7 +116,7 @@ lookupResType gr m c = do
    AnyInd _ n        -> lookupResType gr n c
    ResParam _        -> return $ typePType
    ResValue (Just (t,_))  -> return $ qualifAnnotPar m t
-    _   -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
+    _   -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
  where
    lookFunType e m c = do
          a  <- abstractOfConcrete gr m
@@ -124,7 +128,7 @@ lookupResType gr m c = do
            AbsFun (Just ty) _ _ -> return $ redirectTerm e ty 
            AbsCat _ _ -> return typeType
            AnyInd _ n -> lookFun e m c n
-            _ -> prtBad "cannot find type of reused function" c
+            _ -> Bad (render (text "cannot find type of reused function" <+> ppIdent c))

 lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
 lookupOverload gr m c = do
@@ -138,7 +142,7 @@ lookupOverload gr m c = do
                     concat tss

      AnyInd _ n  -> lookupOverload gr n c
-      _   -> Bad $ prt c +++ "is not an overloaded operation"
+      _   -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")

 -- | returns the original 'Info' and the module where it was found
 lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
@@ -157,7 +161,7 @@ lookupParams gr = look True where
    case info of
      ResParam (Just psm) -> return psm
      AnyInd _ n          -> look False n c
-      _                   -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
+      _                   -> Bad $ render (ppIdent c <+> text "has no parameters defined in resource" <+> ppIdent m)
  lookExt m c =
    checks [look False n c | n <- allExtensions gr m]

@@ -177,21 +181,21 @@ lookupFirstTag gr m c = do
  vs <- lookupParamValues gr m c
  case vs of
    v:_ -> return v
-    _ -> prtBad "no parameter values given to type" c
+    _ -> Bad (render (text "no parameter values given to type" <+> ppIdent c))

 lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
 lookupValueIndex gr ty tr = do
  ts <- allParamValues gr ty
  case lookup tr $ zip ts [0..] of
    Just i -> return $ Val tr ty i
-    _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
+    _ -> Bad $ render (text "no index for" <+> ppTerm Unqualified 0 tr <+> text "in" <+> ppTerm Unqualified 0 ty)

 lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
 lookupIndexValue gr ty i = do
  ts <- allParamValues gr ty
  if i < length ts
    then return $ ts !! i
-    else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
+    else Bad $ render (text "no value for index" <+> int i <+> text "in" <+> ppTerm Unqualified 0 ty)

 allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
 allOrigInfos gr m = errVal [] $ do
@@ -209,7 +213,7 @@ allParamValues cnc ptyp = case ptyp of
       let (ls,tys) = unzip $ sortByFst r
       tss <- mapM allPV tys
       return [R (zipAssign ls ts) | ts <- combinations tss]
-     _ -> prtBad "cannot find parameter values for" ptyp
+     _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
  where
    allPV = allParamValues cnc
    -- to normalize records and record types
@@ -228,7 +232,7 @@ qualifAnnotPar m t = case t of
  _ -> composSafeOp (qualifAnnotPar m) t

 lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
-lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
+lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
  mo <- lookupModule gr m
  info <- lookupIdentInfo mo c
  case info of
@@ -244,7 +248,7 @@ lookupLincat gr m c = do
  case info of
    CncCat (Just t) _ _ -> return t
    AnyInd _ n          -> lookupLincat gr n c
-    _                   -> Bad $ prt c +++ "has no linearization type in" +++ prt m
+    _                   -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))

 -- | this is needed at compile time
 lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -254,7 +258,7 @@ lookupFunType gr m c = do
  case info of
    AbsFun (Just t) _ _  -> return t
    AnyInd _ n           -> lookupFunType gr n c
-    _                    -> prtBad "cannot find type of" c
+    _                    -> Bad (render (text "cannot find type of" <+> ppIdent c))

 -- | this is needed at compile time
 lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -264,7 +268,7 @@ lookupCatContext gr m c = do
  case info of
    AbsCat (Just co) _ -> return co
    AnyInd _ n         -> lookupCatContext gr n c
-    _                  -> prtBad "unknown category" c
+    _                  -> Bad (render (text "unknown category" <+> ppIdent c))

 -- The first type argument is uncomputed, usually a category symbol.
 -- This is a hack to find implicit (= reused) opers.
--- a/src/GF/Grammar/MMacros.hs
+++ b/src/GF/Grammar/MMacros.hs
@@ -18,7 +18,7 @@ import GF.Data.Operations
 --import GF.Data.Zipper

 import GF.Grammar.Grammar
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer
 import GF.Infra.Ident
 import GF.Compile.Refresh
 import GF.Grammar.Values
@@ -27,6 +27,8 @@ import GF.Grammar.Macros

 import Control.Monad
 import qualified Data.ByteString.Char8 as BS
+import Text.PrettyPrint
+
 {-
 nodeTree :: Tree -> TrNode
 argsTree :: Tree -> [Tree]
@@ -178,13 +180,13 @@ val2expP :: Bool -> Val -> Err Exp
 val2expP safe v = case v of

  VClos g@(_:_) e@(Meta _) -> if safe 
-                              then prtBad "unsafe value substitution" v
+                              then Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 v))
                              else substVal g e
  VClos g e -> substVal g e
  VApp f c  -> liftM2 App (val2expP safe f) (val2expP safe c)
  VCn c     -> return $ qq c
  VGen i x  -> if safe 
-               then prtBad "unsafe val2exp" v
+               then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v))
               else return $ Vr $ x  --- in editing, no alpha conversions presentv
  VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs
                  return (RecType xs)
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -24,11 +24,12 @@ import GF.Infra.Ident
 import GF.Grammar.Grammar
 import GF.Grammar.Values
 import GF.Grammar.Predef
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer

 import Control.Monad (liftM, liftM2)
 import Data.Char (isDigit)
 import Data.List (sortBy)
+import Text.PrettyPrint

 firstTypeForm :: Type -> Err (Context, Type)
 firstTypeForm t = case t of
@@ -50,7 +51,7 @@ qTypeForm t = case t of
  QC m c ->
    return ([],(m,c),[]) 
  _       -> 
-    prtBad "no normal form of type" t
+    Bad (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))

 qq :: QIdent -> Term
 qq (m,c) = Q m c
@@ -94,7 +95,7 @@ getMCat t = case t of
  QC m c -> return (m,c)
  Sort c -> return (identW, c)
  App f _ -> getMCat f
-  _ -> prtBad "no qualified constant" t
+  _ -> Bad (render (text "no qualified constant" <+> ppTerm Unqualified 0 t))

 typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
 typeSkeleton typ = do
@@ -231,7 +232,7 @@ mkRecType = mkRecTypeN 0
 record2subst :: Term -> Err Substitution
 record2subst t = case t of
  R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
-  _ -> prtBad "record expected, found" t
+  _    -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))

 typeType, typePType, typeStr, typeTok, typeStrs :: Term

@@ -304,8 +305,8 @@ plusRecType t1 t2 = case (t1, t2) of
  (RecType r1, RecType r2) -> case
    filter (`elem` (map fst r1)) (map fst r2) of
      [] -> return (RecType (r1 ++ r2))
-      ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
-  _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) 
+      ls -> Bad $ render (text "clashing labels" <+> hsep (map ppLabel ls))
+  _ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) 

 plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
@@ -314,7 +315,7 @@ plusRecord t1 t2 =
                              (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
   (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
   (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
-   _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)
+   _ -> Bad $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)

 -- | default linearization type
 defLinType :: Type
@@ -463,7 +464,7 @@ term2patt trm = case termForm trm of
  Ok ([], Cn c, []) -> do
    return (PMacro c)

-  _ -> prtBad "no pattern corresponds to term" trm
+  _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)

 patt2term :: Patt -> Term
 patt2term pt = case pt of
@@ -529,7 +530,7 @@ strsFromTerm t = case t of
  FV ts -> mapM strsFromTerm ts >>= return . concat
  Strs ts -> mapM strsFromTerm ts >>= return . concat  
  Alias _ _ d -> strsFromTerm d --- should not be needed...
-  _ -> prtBad "cannot get Str from term" t
+  _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))

 -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
 stringFromTerm :: Term -> String
@@ -708,10 +709,11 @@ isInOneType t = case t of

 sortRec :: [(Label,a)] -> [(Label,a)]
 sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of
-    ("s",_) -> LT
-    (_,"s") -> GT
-    (s1,s2) -> compare s1 s2
+  ordLabel (r1,_) (r2,_) = 
+    case (showIdent (label2ident r1), showIdent (label2ident r2)) of
+      ("s",_) -> LT
+      (_,"s") -> GT
+      (s1,s2) -> compare s1 s2



--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -21,20 +21,20 @@ import GF.Data.Operations
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Grammar.Macros
-import GF.Grammar.PrGrammar
+import GF.Grammar.Printer

 import Data.List
 import Control.Monad
-
+import Text.PrettyPrint
 import Debug.Trace

 matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
 matchPattern pts term = 
  if not (isInConstantForm term)
-    then prtBad "variables occur in" term
+    then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
  else do
    term' <- mkK term
-    errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
+    errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
      findMatch [([p],t) | (p,t) <- pts] [term']
 where
  -- to capture all Str with string pattern matching
@@ -48,7 +48,7 @@ matchPattern pts term =
    K w -> return [w]
    C v w -> liftM2 (++) (getS v) (getS w)
    Empty -> return []
-    _ -> prtBad "cannot get string from" s
+    _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))

 testOvershadow :: [Patt] -> [Term] -> Err [Patt]
 testOvershadow pts vs = do
@@ -59,10 +59,10 @@ testOvershadow pts vs = do

 findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
 findMatch cases terms = case cases of
-   [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
+   [] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
   (patts,_):_ | length patts /= length terms -> 
-       Bad ("wrong number of args for patterns :" +++ 
-            unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
+       Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> 
+                    text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
       Ok substs -> return (val, concat substs)
       _         -> findMatch cc terms
@@ -122,7 +122,7 @@ tryMatch (p,t) = do

      (PNeg p',_) -> case tryMatch (p',t) of
        Bad _ -> return []
-        _ -> prtBad "no match with negative pattern" p
+        _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))

      (PSeq p1 p2, ([],K s, [])) -> do
         let cuts = [splitAt n s | n <- [0 .. length s]] 
@@ -138,7 +138,7 @@ tryMatch (p,t) = do
      (PChar,  ([],K [_], [])) -> return []
      (PChars cs, ([],K [c], [])) | elem c cs -> return []

-      _ -> prtBad "no match in case expr for" t
+      _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
  
 isInConstantForm :: Term -> Bool
 isInConstantForm trm = case trm of
--- a/src/GF/Grammar/Printer.hs
+++ b/src/GF/Grammar/Printer.hs
@@ -16,11 +16,14 @@ module GF.Grammar.Printer
           , ppTerm
           , ppTermTabular
           , ppPatt
+           , ppValue
+           , ppConstrs
           ) where

 import GF.Infra.Ident
 import GF.Infra.Modules
 import GF.Infra.Option
+import GF.Grammar.Values
 import GF.Grammar.Grammar
 import GF.Data.Operations
 import Text.PrettyPrint
@@ -225,6 +228,22 @@ ppPatt q d (PFloat f)   = double f
 ppPatt q d (PString s)  = str s
 ppPatt q d (PR xs)      = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))

+ppValue :: TermPrintQual -> Int -> Val -> Doc
+ppValue q d (VGen i x)    = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
+ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
+ppValue q d (VCn (_,c))   = ppIdent c
+ppValue q d (VClos env e) = case e of
+                              Meta _ -> ppTerm q d e <> ppEnv env
+                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
+ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
+ppValue q d VType         = text "Type"
+
+ppConstrs :: Constraints -> [Doc]
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
+
+ppEnv :: Env -> Doc
+ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
+
 str s = doubleQuotes (text s)

 ppDecl q (id,typ)
--- a/src/GF/Grammar/Unify.hs
+++ b/src/GF/Grammar/Unify.hs
@@ -18,9 +18,9 @@
 module GF.Grammar.Unify (unifyVal) where

 import GF.Grammar.Abstract
-
 import GF.Data.Operations

+import Text.PrettyPrint
 import Data.List (partition)

 unifyVal :: Constraints -> Err (Constraints,MetaSubst)
@@ -64,13 +64,13 @@ unify e1 e2 g =
                                         unify b c' g
  (App c a, App d b)            -> case unify c d g of 
                                     Ok g1 -> unify a b g1 
-                                     _       -> prtBad "fail unify" e1
+                                     _     -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
  (RecType xs,RecType ys) | xs == ys -> return g
-  _                             -> prtBad "fail unify" e1
+  _                             -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))

 extend :: Unifier -> MetaSymb -> Term -> Err Unifier
 extend g s t | (t == Meta s) = return g  
-             | occCheck s t  = prtBad "occurs check" t
+             | occCheck s t  = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t))
             | True          = return ((s, t) : g) 

 subst_all :: Unifier -> Term -> Err Term