From 30cda5151651e712803527b6ab4e5abc07536f2c Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Sun, 27 Jul 2014 22:06:23 +0000
Subject: [PATCH] Introducing GF.Text.Pretty for more concise pretty printers
 and GF.Infra.Location for modularity

GF.Text.Pretty provides the class Pretty and overloaded versions of the pretty
printing combinators in Text.PrettyPrint, allowing pretty printable values to
be used directly instead of first having to convert them to Doc with functions
like text, int, char and ppIdent. Some modules have been converted to use
GF.Text.Pretty, but not all. Precedences could be added to simplify the pretty
printers for terms and patterns.

GF.Infra.Location contains the types Location and L, factored out from
GF.Grammar.Grammar, and the class HasSourcePath. This allowed the import
of GF.Grammar.Grammar to be removed from GF.Infra.CheckM, making it more
like a pure library module.
---
 src/compiler/GF/Command/Commands.hs           |  28 +-
 src/compiler/GF/Compile.hs                    |  36 +-
 src/compiler/GF/Compile/CheckGrammar.hs       |  35 +-
 .../GF/Compile/Compute/ConcreteNew.hs         |  34 +-
 src/compiler/GF/Compile/GeneratePMCFG.hs      |  42 +--
 src/compiler/GF/Compile/Optimize.hs           |  14 +-
 src/compiler/GF/Compile/Rename.hs             |  30 +-
 .../GF/Compile/TypeCheck/ConcreteNew.hs       |  42 +--
 .../GF/Compile/TypeCheck/RConcrete.hs         | 114 +++----
 src/compiler/GF/Compile/TypeCheck/TC.hs       |  22 +-
 src/compiler/GF/Compile/Update.hs             |  22 +-
 src/compiler/GF/Grammar/Grammar.hs            |  30 +-
 src/compiler/GF/Grammar/Lookup.hs             |  20 +-
 src/compiler/GF/Grammar/Macros.hs             |  24 +-
 src/compiler/GF/Grammar/PatternMatch.hs       |  20 +-
 src/compiler/GF/Grammar/Printer.hs            | 313 +++++++++---------
 src/compiler/GF/Grammar/ShowTerm.hs           |  14 +-
 src/compiler/GF/Infra/CheckM.hs               |  14 +-
 src/compiler/GF/Infra/Ident.hs                |   7 +-
 src/compiler/GF/Infra/UseIO.hs                |   2 +-
 src/compiler/GFI.hs                           |   4 +-
 src/compiler/SimpleEditor/Convert.hs          |   6 +-
 22 files changed, 422 insertions(+), 451 deletions(-)

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index b6a992232..701a98f3b 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -47,7 +47,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 --import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead!
 import GF.System.Process
-import Text.PrettyPrint
+import GF.Text.Pretty
 import Data.List (sort)
 --import Debug.Trace
 --import System.Random (newStdGen) ----
@@ -762,19 +762,19 @@ allCommands = Map.fromList [
                                 Just e  -> let (es,err) = exprs ls
                                            in case inferExpr pgf e of
                                                 Right (e,t) -> (e:es,err)
-                                                Left tcerr  -> (es,text "on line" <+> int n <> colon $$ nest 2 (ppTcError tcerr) $$ err)
+                                                Left tcerr  -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err)
                                 Nothing -> let (es,err) = exprs ls
-                                           in (es,text "on line" <+> int n <> colon <+> text "parse error" $$ err)
+                                           in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
            returnFromLines ls = case exprs ls of
-                                  (es, err) | null es   -> return $ pipeMessage $ render (err $$ text "no trees found")
+                                  (es, err) | null es   -> return $ pipeMessage $ render (err $$ "no trees found")
                                             | otherwise -> return $ pipeWithMessage es (render err)
 
        s <- restricted $ readFile file
        case opts of
          _ | isOpt "lines" opts && isOpt "tree" opts ->
-               returnFromLines (zip [1..] (lines s))
+               returnFromLines (zip [1::Int ..] (lines s))
          _ | isOpt "tree" opts ->
-               returnFromLines [(1,s)]
+               returnFromLines [(1::Int,s)]
          _ | isOpt "lines" opts -> return (fromStrings $ lines s)
          _ -> return (fromString s),
      flags = [("file","the input file name")]
@@ -1145,9 +1145,9 @@ allCommands = Map.fromList [
                                                         render (ppCat id cd $$
                                                                 if null (functionsToCat pgf id)
                                                                   then empty
-                                                                  else space $$
+                                                                  else ' ' $$
                                                                        vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id] $$
-                                                                       space)
+                                                                       ' ')
                                                      let (_,_,prob,_) = cd
                                                      putStrLn ("Probability: "++show prob)
                                                      return void
@@ -1290,7 +1290,7 @@ allCommands = Map.fromList [
      | otherwise            = case po of
                                 ParseOk ts     -> let Piped (es',msg') = fromExprs ts
                                                   in (es'++es,msg'++msg)
-                                TypeError errs -> ([], render (text "The parsing is successful but the type checking failed with error(s):" $$
+                                TypeError errs -> ([], render ("The parsing is successful but the type checking failed with error(s):" $$
                                                                nest 2 (vcat (map (ppTcError . snd) errs)))
                                                        ++ "\n" ++ msg)
                                 ParseFailed i  -> ([], "The parser failed at token " ++ show (words s !! max 0 (i-1))
@@ -1448,13 +1448,13 @@ execToktok (pgf, _) opts exprs = do
 
 trie = render . pptss . toTrie . map toATree
   where
-    pptss [ts] = text "*"<+>nest 2 (ppts ts)
-    pptss tss  = vcat [int i<+>nest 2 (ppts ts)|(i,ts)<-zip [1..] tss]
+    pptss [ts] = "*"<+>nest 2 (ppts ts)
+    pptss tss  = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss]
 
     ppts = vcat . map ppt
 
     ppt t =
       case t of
-        Oth e     -> text (showExpr [] e)
-        Ap f [[]] -> text (showCId f)
-        Ap f tss  -> text (showCId f) $$ nest 2 (pptss tss)
+        Oth e     -> pp (showExpr [] e)
+        Ap f [[]] -> pp (showCId f)
+        Ap f tss  -> showCId f $$ nest 2 (pptss tss)
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index 6cebd2196..207b6cb7c 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -1,4 +1,4 @@
-module GF.Compile (batchCompile, link, srcAbsName, compileToPGF, compileSourceGrammar) where
+module GF.Compile (batchCompile, link, srcAbsName, compileToPGF) where
 import Prelude hiding (catch)
 import GF.System.Catch
 
@@ -32,7 +32,7 @@ import qualified Data.Map as Map
 --import qualified Data.Set as Set
 import Data.List(nub)
 import Data.Time(UTCTime)
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 import PGF.Internal(optimizePGF)
 import PGF
@@ -59,7 +59,7 @@ batchCompile opts files = do
   let cnc = identS (justModuleName (last files))
       t = maximum . map fst $ Map.elems menv
   return (cnc,t,gr)
-
+{-
 -- to compile a set of modules, e.g. an old GF or a .cf file
 compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
 compileSourceGrammar opts gr = do
@@ -68,12 +68,12 @@ compileSourceGrammar opts gr = do
                      emptyCompileEnv
                      (modules gr)
   return gr'
-
+-}
 
 -- to output an intermediate stage
 intermOut :: Options -> Dump -> Doc -> IOE ()
 intermOut opts d doc
-  | dump opts d = ePutStrLn (render (text "\n\n--#" <+> text (show d) $$ doc))
+  | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
   | otherwise   = return ()
 
 warnOut opts warnings
@@ -118,8 +118,8 @@ compileModule opts1 env file = do
                        exists <- liftIO $ doesFileExist file1
                        if exists
                          then return file1
-                         else raise (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1)))
-               else raise (render (text "File" <+> text file <+> text "does not exist."))
+                         else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
+               else raise (render ("File" <+> file <+> "does not exist."))
 
 compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne opts env@(_,srcgr,_) file = do
@@ -171,32 +171,28 @@ compileOne opts env@(_,srcgr,_) file = do
    isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
 
 compileSourceModule :: Options -> FilePath -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
-compileSourceModule opts cwd env@(k,gr,_) mb_gfFile mo@(i,mi) = do
+compileSourceModule opts cwd env@(k,gr,_) mb_gfFile mo0@(i,mi) = do
 
-  mo1  <- runPass Rebuild "" (rebuildModule cwd gr mo)
-  mo1b <- runPass Extend "" (extendModule cwd gr mo1)
+  mo1a <- runPass Rebuild "" (rebuildModule cwd gr mo0)
+  mo1b <- runPass Extend "" (extendModule cwd gr mo1a)
 
   case mo1b of
-    (_,n) | not (isCompleteModule n) ->
-      if tagsFlag then generateTags k mo1b else generateGFO k mo1b
+    (_,n) | not (isCompleteModule n) -> generateTagsOr generateGFO k mo1b
     _ -> do
       mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1b
       mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2
-      if tagsFlag then generateTags k mo3 else compileCompleteModule k mo3
+      generateTagsOr compileCompleteModule k mo3
   where
     compileCompleteModule k mo3 = do
---    (k',mo3r:_) <- runPass2 (head.snd) Refresh "refreshing" $
---                   refreshModule (k,gr) mo3
-      let k' = k
-          mo3r = mo3
-      mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3r
+      mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3
       mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
              then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
              else runPass2' "" $ return mo4
-      generateGFO k' mo5
+      generateGFO k mo5
 
   ------------------------------
-    tagsFlag = flag optTagsOnly opts
+    generateTagsOr compile =
+       if flag optTagsOnly opts then generateTags else compile
 
     generateGFO k mo =
       do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 5f2e94f68..10cbd4bb9 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -42,7 +42,7 @@ import GF.Infra.CheckM
 import Data.List
 import qualified Data.Set as Set
 import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 -- | checking is performed in the dependency order of modules
 checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -78,8 +78,8 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
            (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
      case illegals of 
        [] -> return ()
-       cs -> checkWarn (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$
-                         nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
+       cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
+                         nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
    allDeps = concatMap (allDependencies (const True) . jments . snd) mos
 
 checkCompleteGrammar :: Options -> FilePath -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
@@ -126,15 +126,15 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                        Bad _  -> do noLinOf c
                                     return js
          where noLinOf c = when (verbAtLeast opts Normal) $
-                           checkWarn (text "no linearization of" <+> ppIdent c)
+                           checkWarn ("no linearization of" <+> c)
        AbsCat (Just _) -> case lookupIdent c js of
          Ok (AnyInd _ _) -> return js
          Ok (CncCat (Just _) _ _ _ _) -> return js
          Ok (CncCat Nothing md mr mp mpmcfg) -> do
-           checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
+           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
            return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
          _ -> do
-           checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
+           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
            return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
        _ -> return js
      
@@ -145,11 +145,11 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                                         do (cont,val) <- linTypeOfType gr cm ty
                                            let linty = (snd (valCat ty),cont,val)
                                            return $ updateTree (c,CncFun (Just linty) d mn mf) js
-                             _       -> do checkWarn (text "function" <+> ppIdent c <+> text "is not in abstract")
+                             _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
                                            return js
        CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
                              Ok _ -> return $ updateTree i js
-                             _    -> do checkWarn (text "category" <+> ppIdent c <+> text "is not in abstract")
+                             _    -> do checkWarn ("category" <+> c <+> "is not in abstract")
                                         return js
        _                -> return $ updateTree i js
 
@@ -241,7 +241,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
-             checkError (text "No definition given to the operation")
+             checkError (pp "No definition given to the operation")
       return (ResOper pty' pde')
 
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
@@ -263,8 +263,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
     _ ->  return info
  where
    gr = prependModule sgr (m,mo)
-   chIn loc cat = checkInModule cwd mo loc
-                             (text "Happened in" <+> text cat <+> ppIdent c)
+   chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
 
    mkPar (f,co) = do
        vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
@@ -272,7 +271,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
 
    checkUniq xss = case xss of
      x:y:xs 
-      | x == y    -> checkError $ text "ambiguous for type" <+>
+      | x == y    -> checkError $ "ambiguous for type" <+>
                                   ppType (mkFunType (tail x) (head x))  
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
@@ -282,7 +281,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
      _ -> chIn loc cat $ checkError (vcat ss)
 
    compAbsTyp g t = case t of
-     Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
+     Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
      Let (x,(_,a)) b -> do
        a' <- compAbsTyp g a
        compAbsTyp ((x, a'):g) b
@@ -298,7 +297,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
 checkReservedId :: Ident -> Check ()
 checkReservedId x =
   when (isReservedWord x) $
-       checkWarn (text "reserved word used as identifier:" <+> ppIdent x)
+       checkWarn ("reserved word used as identifier:" <+> x)
 
 -- auxiliaries
 
@@ -315,10 +314,10 @@ linTypeOfType cnc m typ = do
      let vars = mkRecType varLabel $ replicate n typeStr
 	 symb = argIdent n cat i
      rec <- if n==0 then return val else
-                       errIn (render (text "extending" $$
-                                      nest 2 (ppTerm Unqualified 0 vars) $$
-                                      text "with" $$
-                                      nest 2 (ppTerm Unqualified 0 val))) $
+                       errIn (render ("extending" $$
+                                      nest 2 vars $$
+                                      "with" $$
+                                      nest 2 val)) $
                              plusRecType vars val
      return (Explicit,symb,rec)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
index 7c471f1cc..c4793c023 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -1,7 +1,7 @@
 -- | Functions for computing the values of terms in the concrete syntax, in
 -- | preparation for PMCFG generation.
 module GF.Compile.Compute.ConcreteNew
-           (GlobalEnv, resourceValues, normalForm, ppL
+           (GlobalEnv, resourceValues, normalForm,
            --, Value(..), Env, value2term, eval, apply
            ) where
 
@@ -18,7 +18,7 @@ import GF.Data.Utilities(mapFst,mapSnd,mapBoth)
 import Control.Monad(ap,liftM,liftM2,mplus,unless)
 import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
 --import Data.Char (isUpper,toUpper,toLower)
-import Text.PrettyPrint
+import GF.Text.Pretty
 import qualified Data.Map as Map
 --import Debug.Trace(trace)
 
@@ -109,7 +109,7 @@ value env t0 =
                                       brackets (fsep (map ppIdent (local env))),
                                       ppT 10 t0]) $
 --}
-  errIn (render $ ppT 0 t0) $
+  errIn (render t0) $
   case t0 of
     Vr x   -> var env x
     Q x@(m,f)
@@ -158,7 +158,7 @@ value env t0 =
     Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
     ELin c r -> (unlockVRec c.) # value env r
     EPatt p  -> return $ const (VPatt p) -- hmm
-    t -> fail.render $ text "value"<+>ppT 10 t $$ text (show t)
+    t -> fail.render $ "value"<+>ppT 10 t $$ show t
 
 paramValues env ty = do let ge = global env
                         ats <- allParamValues (srcgr env) =<< nfx ge ty
@@ -216,15 +216,15 @@ extR t vv =
       (VRecType rs1, VRecType rs2) ->
           case intersect (map fst rs1) (map fst rs2) of
             [] -> VRecType (rs1 ++ rs2)
-            ls -> error $ text "clash"<+>text (show ls)
+            ls -> error $ "clash"<+>show ls
       (VRec     rs1, VRec     rs2) -> plusVRec rs1 rs2
       (v1          , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
       (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
       (v1,v2) -> ok2 VExtR v1 v2 -- hmm
 --    (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2)
   where
-    error explain = ppbug $ text "The term" <+> ppT 0 t
-                            <+> text "is not reducible" $$ explain
+    error explain = ppbug $ "The term" <+> t
+                            <+> "is not reducible" $$ explain
 
 glue env (v1,v2) = glu v1 v2
   where
@@ -249,8 +249,8 @@ glue env (v1,v2) = glu v1 v2
           (_,v2@(VApp NonExist _)) -> v2
 --        (v1,v2) -> ok2 VGlue v1 v2
           (v1,v2) -> error . render $
-                     ppL loc (hang (text "unsupported token gluing:") 4
-                                   (ppT 0 (Glue (vt v1) (vt v2))))
+                     ppL loc (hang "unsupported token gluing:" 4
+                                   (Glue (vt v1) (vt v2)))
 
     vt = value2term loc (local env)
     loc = gloc env
@@ -331,7 +331,7 @@ valueTable env i cs =
                              pvs = nub allpvs
                              dups = allpvs \\ pvs
                          unless (null dups) $
-                           fail.render $ hang (text "Pattern is not linear:") 4
+                           fail.render $ hang "Pattern is not linear:" 4
                                               (ppPatt Unqualified 0 p')
                          vt <- value (extend pvs env) t
                          return (p', \ vs -> Bind $ \ bs -> vt (push' p' bs pvs vs))
@@ -350,8 +350,8 @@ valueTable env i cs =
           PM qc -> do r <- resource env qc
                       case r of
                         VPatt p' -> inlinePattMacro p'
-                        _ -> ppbug $ hang (text "Expected pattern macro:") 4
-                                          (text (show r))
+                        _ -> ppbug $ hang "Expected pattern macro:" 4
+                                          (show r)
           _ -> composPattOp inlinePattMacro p
 --}
 
@@ -498,11 +498,7 @@ both f (x,y) = (,) # f x <# f y
 
 ppT = ppTerm Unqualified
 
-ppL (L loc x) msg = hang (ppLocation "" loc<>colon) 4
-                         (text "In"<+>ppIdent x<>colon<+>msg)
+bugloc loc s = ppbug $ ppL loc s
 
-bugloc loc s = ppbug $ ppL loc (text s)
-
-bug msg = ppbug (text msg)
-ppbug doc = error $ render $
-                    hang (text "Internal error in Compute.ConcreteNew:") 4 doc
+bug msg = ppbug msg
+ppbug doc = error $ render $ hang "Internal error in Compute.ConcreteNew:" 4 doc
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index 9bd7c176f..b8edda00f 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -25,13 +25,13 @@ import GF.Data.BacktrackM
 import GF.Data.Operations
 import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn)
 import GF.Data.Utilities (updateNthM) --updateNth
-import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
 --import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
-import Text.PrettyPrint hiding (Str)
+import GF.Text.Pretty
 import Data.Array.IArray
 import Data.Array.Unboxed
 --import Data.Maybe
@@ -148,13 +148,13 @@ floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
 
 convert opts gr cenv loc term ty@(_,val) pargs =
     case term' of
-      Error s -> fail $ render $ ppL loc (text $ "Predef.error: "++s)
+      Error s -> fail $ render $ ppL loc ("Predef.error: "++s)
       _ -> do {-when (verbAtLeast opts Verbose) $
                 ePutStrLn $
                   "\n"++take 10000 (renderStyle style{mode=OneLineMode}
-                    (text "term:"<+>ppU 0 term $$
-                     text "eta expanded:"<+>ppU 0 eterm $$
-                     text "normalized:"<+>ppU 0 term'))--}
+                    (text "term:"<+>term $$
+                     text "eta expanded:"<+>eterm $$
+                     text "normalized:"<+>term'))--}
               return $ runCnvMonad gr (conv term') (pargs,[])
   where
     conv t = convertTerm opts CNil val =<< unfactor t
@@ -189,16 +189,16 @@ unfactor t = CM (\gr c -> c (unfac gr t))
       case t of
         T (TTyped ty) [(PV x,u)] -> let u' = unfac gr u
                                         vs = allparams ty
-                                    in --trace ("expand single variable table into "++show (length vs)++" branches.\n"++render (ppU 0 t)) $
+                                    in --trace ("expand single variable table into "++show (length vs)++" branches.\n"++render t) $
                                        V ty [restore x v u' | v <- vs]
         T (TTyped ty) [(PW  ,u)] -> let u' = unfac gr u
                                         vs = allparams ty
-                                    in --trace ("expand wildcard table into "++show (length vs)++ "branches.\n"++render (ppU 0 t)) $
+                                    in --trace ("expand wildcard table into "++show (length vs)++ "branches.\n"++render t) $
                                        V ty [u' | _ <- vs]
         T (TTyped ty) _ -> -- convertTerm doesn't handle these tables
                            ppbug $
-                           sep [text "unfactor"<+>ppU 10 t,
-                                text (show t){-,
+                           sep ["unfactor"<+>ppU 10 t,
+                                pp (show t){-,
                                 fsep (map (ppU 10) (allparams ty))-}]
         _ -> composSafeOp (unfac gr) t
       where
@@ -376,7 +376,7 @@ computeCatRange gr lincat = compute (0,1) lincat
                                      (index,m) = st
                                  in ((index,m*length vs),CPar (m,zip vs [0..]))
 
-ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
+ppPath (CProj lbl path) = lbl <+> ppPath path
 ppPath (CSel  trm path) = ppU 5 trm   <+> ppPath path
 ppPath CNil             = empty
 
@@ -417,7 +417,7 @@ convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil cty
   where
     unSym (CStr [])        = ""
     unSym (CStr [SymKS t]) = t
-    unSym _                = ppbug $ hang (text "invalid prefix in pre expression:") 4 (ppU 0 (Alts s alts))
+    unSym _                = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts)
 
     unPatt (EPatt p) = fmap Strs (getPatts p)
     unPatt u         = return u
@@ -429,7 +429,7 @@ convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil cty
         as <- getPatts a
         bs <- getPatts b
         return [K (s ++ t) | K s <- as, K t <- bs]
-      _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
+      _ -> fail (render ("not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
 
 convertTerm opts sel ctype (Q (m,f))
   | m == cPredef &&
@@ -449,7 +449,7 @@ convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
 
 convertTerm opts CNil ctype t           = do v <- evalTerm CNil t
                                              return (CPar v)
-convertTerm _    sel  _     t           = ppbug (text "convertTerm" <+> sep [parens (text (show sel)),ppU 10 t])
+convertTerm _    sel  _     t           = ppbug ("convertTerm" <+> sep [parens (show sel),ppU 10 t])
 
 convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
 convertArg opts (RecType rs)  nr path =
@@ -489,8 +489,8 @@ convertTbl opts (CSel v sub_sel) ctype pt ts = do
   vs <- getAllParamValues pt
   case lookup v (zip vs ts) of
     Just t  -> convertTerm opts sub_sel ctype t
-    Nothing -> ppbug (text "convertTbl:" <+> (text "missing value" <+> ppU 0 v $$
-                                              text "among" <+> vcat (map (ppU 0) vs)))
+    Nothing -> ppbug ( "convertTbl:" <+> ("missing value" <+> v $$
+                                          "among" <+> vcat vs))
 convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
 
 
@@ -571,13 +571,13 @@ evalTerm path (V pt ts)    =
          do vs <- getAllParamValues pt
             case lookup trm (zip vs ts) of
               Just t  -> evalTerm path t
-              Nothing -> ppbug $ text "evalTerm: missing value:"<+>ppU 0 trm
-                                 $$ text "among:" <+>fsep (map (ppU 10) vs)
+              Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
+                                 $$ "among:" <+>fsep (map (ppU 10) vs)
 evalTerm path (S term sel) = do v <- evalTerm CNil sel
                                 evalTerm (CSel v path) term
 evalTerm path (FV terms)   = variants terms >>= evalTerm path
 evalTerm path (EInt n)     = return (EInt n)
-evalTerm path t            = ppbug (text "evalTerm" <+> parens (ppU 0 t))
+evalTerm path t            = ppbug ("evalTerm" <+> parens t)
 --evalTerm path t            = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
 
 getVarIndex x = maybe err id $ getArgIndex x
@@ -654,7 +654,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
 mkArray    lst = listArray (0,length lst-1) lst
 mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
 
-bug msg = ppbug (text msg)
-ppbug = error . render . hang (text "Internal error in GeneratePMCFG:") 4
+bug msg = ppbug msg
+ppbug msg = error . render $ hang "Internal error in GeneratePMCFG:" 4 msg
 
 ppU = ppTerm Unqualified
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index ad4f42b50..0d45825f1 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -34,7 +34,7 @@ import GF.Infra.Option
 import Control.Monad
 --import Data.List
 import qualified Data.Set as Set
-import Text.PrettyPrint
+import GF.Text.Pretty
 import Debug.Trace
 
 
@@ -89,7 +89,7 @@ evalInfo opts resenv sgr m c info = do
     return (CncCat ptyp pde' pre' ppr' mpmcfg)
 
   CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
-       eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
+       eIn ("linearization in type" <+> mkProd cont val [] $$ "of function") $ do
     pde' <- case pde of
       Just (L loc de) -> do de <- partEval opts gr (cont,val) de
                             return (Just (L loc (factor param c 0 de)))
@@ -112,7 +112,7 @@ evalInfo opts resenv sgr m c info = do
    gr = prependModule sgr m
    optim = flag optOptimizations opts
    param = OptParametrize `Set.member` optim
-   eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
+   eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
 
 -- | the main function for compiling linearizations
 partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
@@ -121,7 +121,7 @@ partEval opts = {-if flag optNewComp opts
                 {-else partEvalOld opts-}
 
 partEvalNew opts gr (context, val) trm =
-    errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $
+    errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
     checkPredefError trm
 {-
 partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
@@ -169,13 +169,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
      QC p           -> do vs <- lookupParamValues gr p
                           case vs of
                             v:_ -> return v
-                            _   -> Bad (render (text "no parameter values given to type" <+> ppQIdent Qualified p))
+                            _   -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
      RecType r  -> do
        let (ls,ts) = unzip r
        ts <- mapM mkDefField ts
        return $ R (zipWith assign ls ts)
      _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
-     _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
+     _ -> Bad (render ("linearization type field cannot be" <+> typ))
 
 mkLinReference :: SourceGrammar -> Type -> Err Term
 mkLinReference gr typ = 
@@ -196,7 +196,7 @@ mkLinReference gr typ =
        RecType rs -> do
          msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
        _ | Just _ <- isTypeInts typ -> Bad "no string"
-       _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
+       _ -> Bad (render ("linearization type field cannot be" <+> typ))
 
 evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term
 evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr)
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 2974a1a36..6ade83a8c 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -40,7 +40,7 @@ import GF.Data.Operations
 
 import Control.Monad
 import Data.List (nub,(\\))
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 -- | this gives top-level access to renaming term input in the cc command
 renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
@@ -97,8 +97,8 @@ renameIdentTerm' env@(act,imps) t0 =
         Ok f -> return (f c)
         _    -> case lookupTreeManyAll showIdent opens c of
                   [f]  -> return (f c)
-                  []   -> alt c (text "constant not found:" <+> ppIdent c $$
-                                 text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs)))
+                  []   -> alt c ("constant not found:" <+> c $$
+                                 "given" <+> fsep (punctuate ',' (map fst qualifs)))
                   fs   -> case nub [f c | f <- fs]  of
                             [tr]     -> return tr
 {-
@@ -106,9 +106,9 @@ renameIdentTerm' env@(act,imps) t0 =
                                         -- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014
                                         -- the old definition is below and still presupposed in TypeCheck.Concrete
 -}
-                            ts@(t:_) -> do checkWarn (text "atomic term" <+> ppTerm Qualified 0 t0 $$
-                                                      text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)) $$
-                                                      text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs)))
+                            ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
+                                                      "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
+                                                      "given" <+> fsep (punctuate ',' (map fst qualifs)))
                                            return t
 
             -- a warning will be generated in CheckGrammar, and the head returned
@@ -171,7 +171,7 @@ renameInfo cwd status (m,mi) i info =
     renMaybe ren Nothing  = return Nothing
 
     renLoc ren (L loc x) =
-      checkInModule cwd mi loc (text "Happened in the renaming of" <+> ppIdent i) $ do
+      checkInModule cwd mi loc ("Happened in the renaming of" <+> i) $ do
         x <- ren x
         return (L loc x)
 
@@ -222,7 +222,7 @@ renameTerm env vars = ren vars where
       | elem r vs -> return trm                                -- try var proj first ..
       | otherwise -> checks [ renid' (Q (r,label2ident l))      -- .. and qualified expression second.
                             , renid' t >>= \t -> return (P t l) -- try as a constant at the end
-                            , checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 trm)
+                            , checkError ("unknown qualified constant" <+> trm)
                             ]
 
     EPatt p -> do
@@ -244,8 +244,8 @@ renamePattern :: Status -> Patt -> Check (Patt,[Ident])
 renamePattern env patt =
     do r@(p',vs) <- renp patt
        let dupl = vs \\ nub vs
-       unless (null dupl) $ checkError (hang (text "[C.4.13] Pattern is not linear:") 4
-                                             (ppPatt Unqualified 0 patt))
+       unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear:") 4
+                                             patt)
        return r
   where
     renp patt = case patt of
@@ -253,7 +253,7 @@ renamePattern env patt =
         c' <- renid $ Vr c
         case c' of
           Q d -> renp $ PM d
-          _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
+          _ -> checkError ("unresolved pattern" <+> patt)
 
       PC c ps -> do
         c' <- renid $ Cn c
@@ -261,8 +261,8 @@ renamePattern env patt =
           QC c -> do psvss <- mapM renp ps
                      let (ps,vs) = unzip psvss
                      return (PP c ps, concat vs)
-          Q  _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
-          _    -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
+          Q  _ -> checkError ("data constructor expected but" <+> ppTerm Qualified 0 c' <+> "is found instead")
+          _    -> checkError ("unresolved data constructor" <+> ppTerm Qualified 0 c')
 
       PP c ps -> do
         (QC c') <- renid (QC c)
@@ -274,12 +274,12 @@ renamePattern env patt =
         x <- renid (Q c)
         c' <- case x of
                 (Q c') -> return c'
-                _      -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
+                _      -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
         return (PM c', [])
 
       PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
                                                  QC c -> return (PP c [],[])
-                                                 _    -> checkError (text "not a constructor")
+                                                 _    -> checkError (pp "not a constructor")
                      , return (patt, [x])
                      ]
 
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index 7f78e4c40..67f6e5fda 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -10,7 +10,7 @@ import GF.Infra.CheckM
 --import GF.Infra.UseIO
 import GF.Data.Operations
 
-import Text.PrettyPrint
+import GF.Text.Pretty
 import Data.List (nub, (\\), tails)
 import qualified Data.IntMap as IntMap
 
@@ -48,7 +48,7 @@ checkSigma gr scope t sigma = do                                -- GEN2
   let bad_tvs = filter (`elem` esc_tvs) skol_tvs
   if null bad_tvs
     then return (abs t)
-    else tcError (text "Type not polymorphic enough")
+    else tcError (pp "Type not polymorphic enough")
 
 tcRho :: SourceGrammar -> Scope -> Term -> Maybe Rho -> TcM (Term, Rho)
 tcRho gr scope t@(EInt _)   mb_ty = instSigma gr scope t (eval gr [] typeInt)   mb_ty
@@ -58,20 +58,20 @@ tcRho gr scope t@(Empty)    mb_ty = instSigma gr scope t (eval gr [] typeStr)
 tcRho gr scope t@(Vr v)     mb_ty = do                          -- VAR
   case lookup v scope of
     Just v_sigma -> instSigma gr scope t v_sigma mb_ty
-    Nothing      -> tcError (text "Unknown variable" <+> ppIdent v)
+    Nothing      -> tcError ("Unknown variable" <+> v)
 tcRho gr scope t@(Q id)     mb_ty
   | elem (fst id) [cPredef,cPredefAbs] = 
       case typPredefined (snd id) of
         Just ty -> instSigma gr scope t (eval gr [] ty) mb_ty
-        Nothing -> tcError (text "unknown in Predef:" <+> ppQIdent Qualified id)
+        Nothing -> tcError (pp "unknown in Predef:" <+> ppQIdent Qualified id)
   | otherwise = do
       case lookupResType gr id of
         Ok ty   -> instSigma gr scope t (eval gr [] ty) mb_ty
-        Bad err -> tcError (text err)
+        Bad err -> tcError (pp err)
 tcRho gr scope t@(QC id)     mb_ty = do
   case lookupResType gr id of
     Ok ty   -> instSigma gr scope t (eval gr [] ty) mb_ty
-    Bad err -> tcError (text err)
+    Bad err -> tcError (pp err)
 tcRho gr scope (App fun arg) mb_ty = do                         -- APP
   (fun,fun_ty) <- tcRho gr scope fun Nothing
   (arg_ty, res_ty) <- unifyFun gr scope (eval gr (scopeEnv scope) arg) fun_ty
@@ -148,9 +148,9 @@ tcRho gr scope t@(R rs) mb_ty = do
              Just ty -> case ty of
                           VRecType ltys -> checkRecFields gr scope rs ltys
                           VMeta _ _ _   -> inferRecFields gr scope rs
-                          _             -> tcError (text "Record type is inferred but:" $$
+                          _             -> tcError ("Record type is inferred but:" $$
                                                     nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) ty)) $$
-                                                    text "is expected in the expresion:" $$
+                                                    "is expected in the expresion:" $$
                                                     nest 2 (ppTerm Unqualified 0 t))
   return (R        [(l, (Just (value2term gr (scopeVars scope) ty), t)) | (l,t,ty) <- lttys], 
           VRecType [(l, ty)                                             | (l,t,ty) <- lttys]
@@ -177,9 +177,9 @@ tcRho gr scope t@(ExtR t1 t2) mb_ty = do
     (VSort s1,VSort s2)
        | s1 == cType && s2 == cType -> instSigma gr scope (ExtR t1 t2) (VSort cType) mb_ty
     (VRecType rs1, VRecType rs2) 
-       | otherwise                  -> do tcWarn (text "bbbb")
+       | otherwise                  -> do tcWarn (pp "bbbb")
                                           instSigma gr scope (ExtR t1 t2) (VRecType (rs1 ++ rs2)) mb_ty
-    _                               -> tcError (text "Cannot type check" <+> ppTerm Unqualified 0 t)
+    _                               -> tcError ("Cannot type check" <+> ppTerm Unqualified 0 t)
 tcRho gr scope (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
   tcRho gr scope (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
 tcRho gr scope (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
@@ -216,7 +216,7 @@ tcPatt gr scope (PP c ps) ty0 =
                  (scope,ty) <- go scope (eval gr [] ty) ps
                  unify gr scope ty0 ty
                  return scope
-    Bad err -> tcError (text err)
+    Bad err -> tcError (pp err)
 tcPatt gr scope (PString s) ty0 = do
   unify gr scope ty0 (eval gr [] typeStr)
   return scope
@@ -252,13 +252,13 @@ inferRecFields gr scope rs =
 
 checkRecFields gr scope []          ltys
   | null ltys                            = return []
-  | otherwise                            = tcError (text "Missing fields:" <+> hsep (map (ppLabel . fst) ltys))
+  | otherwise                            = tcError ("Missing fields:" <+> hsep (map fst ltys))
 checkRecFields gr scope ((l,t):lts) ltys =
   case takeIt l ltys of
     (Just ty,ltys) -> do ltty  <- tcRecField gr scope l t (Just ty)
                          lttys <- checkRecFields gr scope lts ltys
                          return (ltty : lttys)
-    (Nothing,ltys) -> do tcWarn (text "Discarded field:" <+> ppLabel l)
+    (Nothing,ltys) -> do tcWarn ("Discarded field:" <+> l)
                          ltty  <- tcRecField gr scope l t Nothing
                          lttys <- checkRecFields gr scope lts ltys
                          return lttys     -- ignore the field
@@ -298,9 +298,9 @@ subsCheck gr scope t sigma1 sigma2 = do                        -- DEEP-SKOL
   let bad_tvs = filter (`elem` esc_tvs) skol_tvs
   if null bad_tvs
     then return (abs t)
-    else tcError (vcat [text "Subsumption check failed:",
+    else tcError (vcat [pp "Subsumption check failed:",
                         nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma1)),
-                        text "is not as polymorphic as",
+                        pp "is not as polymorphic as",
                         nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma2))])
 
 
@@ -365,8 +365,8 @@ unify gr scope (VRecType rs1) (VRecType rs2) = do
 unify gr scope v1 v2 = do
   t1 <- zonkTerm (value2term gr (scopeVars scope) v1)
   t2 <- zonkTerm (value2term gr (scopeVars scope) v2)
-  tcError (text "Cannot unify types:" <+> (ppTerm Unqualified 0 t1 $$ 
-                                           ppTerm Unqualified 0 t2))
+  tcError ("Cannot unify types:" <+> (ppTerm Unqualified 0 t1 $$ 
+                                      ppTerm Unqualified 0 t2))
 
 -- | Invariant: tv1 is a flexible type variable
 unifyVar :: SourceGrammar -> Scope -> MetaId -> Env -> [Value] -> Tau -> TcM ()
@@ -377,7 +377,7 @@ unifyVar gr scope i env vs ty2 = do            -- Check whether i is bound
     Unbound _ -> do let ty2' = value2term gr (scopeVars scope) ty2
                     ms2 <- getMetaVars gr [(scope,ty2)]
                     if i `elem` ms2
-                      then tcError (text "Occurs check for" <+> ppMeta i <+> text "in:" $$
+                      then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
                                     nest 2 (ppTerm Unqualified 0 ty2'))
                       else setMeta i (Bound ty2')
 
@@ -465,7 +465,7 @@ instance Monad TcM where
   f >>= g  = TcM (\ms msgs -> case unTcM f ms msgs of
                                 TcOk x ms msgs -> unTcM (g x) ms msgs
                                 TcFail    msgs -> TcFail msgs)
-  fail     = tcError . text
+  fail     = tcError . pp
 
 instance Functor TcM where
   fmap f g = TcM (\ms msgs -> case unTcM g ms msgs of
@@ -476,7 +476,7 @@ tcError :: Message -> TcM a
 tcError msg = TcM (\ms msgs -> TcFail (msg : msgs))
 
 tcWarn :: Message -> TcM ()
-tcWarn msg = TcM (\ms msgs -> TcOk () ms ((text "Warning:" <+> msg) : msgs))
+tcWarn msg = TcM (\ms msgs -> TcOk () ms (("Warning:" <+> msg) : msgs))
 
 unimplemented str = fail ("Unimplemented: "++str)
 
@@ -494,7 +494,7 @@ getMeta :: MetaId -> TcM MetaValue
 getMeta i = TcM (\ms msgs -> 
   case IntMap.lookup i ms of
     Just mv -> TcOk mv ms msgs
-    Nothing -> TcFail ((text "Unknown metavariable" <+> ppMeta i) : msgs))
+    Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
 
 setMeta :: MetaId -> MetaValue -> TcM ()
 setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)
diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
index 16c6908da..ca8d789c1 100644
--- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
@@ -13,7 +13,7 @@ import GF.Compile.TypeCheck.Primitives
 
 import Data.List
 import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 computeLType :: SourceGrammar -> Context -> Type -> Check Type
 computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
@@ -22,7 +22,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
     _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
       | isPredefConstant ty     -> return ty ---- shouldn't be needed
 
-    Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
+    Q (m,ident) -> checkIn ("module" <+> m) $ do
       ty' <- lookupResDef gr (m,ident)
       if ty' == ty then return ty else comp g ty' --- is this necessary to test?
 
@@ -30,7 +30,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
      over <- getOverload gr g (Just typeType) t
      case over of
        Just (tr,_) -> return tr
-       _ -> checkError (text "unresolved overloading of constants" <+> ppTerm Qualified 0 t) 
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t) 
 
     Vr ident  -> checkLookup ident g -- never needed to compute!
 
@@ -79,26 +79,26 @@ inferLType gr g trm = case trm of
 
    Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
                                                 Just ty -> return ty
-                                                Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
+                                                Nothing -> checkError ("unknown in Predef:" <+> ident)
 
    Q ident -> checks [
      termWith trm $ lookupResType gr ident >>= computeLType gr g
      ,
      lookupResDef gr ident >>= inferLType gr g
      ,
-     checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
+     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
      ]
 
    QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
                                                  Just ty -> return ty
-                                                 Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
+                                                 Nothing -> checkError ("unknown in Predef:" <+> ident)
 
    QC ident -> checks [
        termWith trm $ lookupResType gr ident >>= computeLType gr g
        ,
        lookupResDef gr ident >>= inferLType gr g
        ,
-       checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
+       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
        ]
 
    Vr ident -> termWith trm $ checkLookup ident g
@@ -111,7 +111,7 @@ inferLType gr g trm = case trm of
      over <- getOverload gr g Nothing trm
      case over of
        Just trty -> return trty
-       _ -> checkError (text "unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
 
    App f a -> do
      over <- getOverload gr g Nothing trm
@@ -127,7 +127,7 @@ inferLType gr g trm = case trm of
                       then return val
                       else substituteLType [(bt,z,a')] val
              return (App f' a',ty) 
-           _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty)
+           _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
 
    S f x -> do
      (f', fty) <- inferLType gr g f
@@ -135,7 +135,7 @@ inferLType gr g trm = case trm of
        Table arg val -> do
          x'<- justCheck g x arg
          return (S f' x', val)
-       _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
+       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
 
    P t i -> do
      (t',ty) <- inferLType gr g t   --- ??
@@ -143,16 +143,16 @@ inferLType gr g trm = case trm of
      let tr2 = P t' i
      termWith tr2 $ case ty' of
        RecType ts -> case lookup i ts of
-                       Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
+                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
                        Just x  -> return x
-       _          -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
+       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
+                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
 
    R r -> do
      let (ls,fs) = unzip r
      fsts <- mapM inferM fs
      let ts = [ty | (Just ty,_) <- fsts]
-     checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
+     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
      return $ (R (zip ls fsts), RecType (zip ls ts))
 
    T (TTyped arg) pts -> do
@@ -164,7 +164,7 @@ inferLType gr g trm = case trm of
    T ti pts -> do  -- tries to guess: good in oper type inference
      let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
      case pts' of 
-       [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm)
+       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
 ----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] 
        _  -> do 
          (arg,val) <- checks $ map (inferCase Nothing) pts'
@@ -198,7 +198,7 @@ inferLType gr g trm = case trm of
 
 ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
    Strs (Cn c : ts) | c == cConflict -> do
-     checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
+     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
      inferLType gr g (head ts)
 
    Strs ts -> do
@@ -231,7 +231,7 @@ inferLType gr g trm = case trm of
          checkLType gr g trm' rt ---- return (trm', rt)
        _ | rT' == typeType && sT' == typeType -> do
          return (trm', typeType)
-       _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
+       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
 
    Sort _     -> 
      termWith trm $ return typeType
@@ -263,7 +263,7 @@ inferLType gr g trm = case trm of
      ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
      return $ (ELin c trm', ty') 
 
-   _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
+   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
 
  where
    isPredef m = elem m [cPredef,cPredefAbs]
@@ -352,25 +352,25 @@ getOverload gr g mt ot = case appForm ot of
      case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
        ([(_,val,fun)],_) -> return (mkApp fun tts, val)
        ([],[(pre,val,fun)]) -> do
-         checkWarn $  text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      text "for" $$
+         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
+                      "for" $$
                       nest 2 (showTypes tys) $$
-                      text "using" $$
+                      "using" $$
                       nest 2 (showTypes pre)
          return (mkApp fun tts, val)
        ([],[]) -> do
-         checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
-                      text "for" $$
+         checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$
+                      "for" $$
                       nest 2 stysError $$
-                      text "among" $$
+                      "among" $$
                       nest 2 (vcat stypsError) $$
-                      maybe empty (\x -> text "with value type" <+> ppType x) mt
+                      maybe empty (\x -> "with value type" <+> ppType x) mt
 
        (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
          ([(val,fun)],_) -> do
            return (mkApp fun tts, val)
          ([],[(val,fun)]) -> do
-           checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) 
+           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) 
            return (mkApp fun tts, val)
 
 ----- unsafely exclude irritating warning AR 24/5/2008
@@ -382,9 +382,9 @@ getOverload gr g mt ot = case appForm ot of
 --  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before. 
 --  But it also gives a chance to ambiguous overloadings that were banned before. 
          (nps1,nps2) -> do 
-              checkWarn $  text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
-                  ----     text "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$ 
-                           text "resolved by selecting the first of the alternatives" $$
+              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
+                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$ 
+                           "resolved by selecting the first of the alternatives" $$
                            nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
               return $ head [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2]
 
@@ -421,10 +421,10 @@ checkLType gr g trm typ0 = do
         Prod bt' z a b -> do 
           (c',b') <- if isWildIdent z
                        then checkLType gr ((bt,x,a):g) c b
-                       else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b
+                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
                                checkLType gr ((bt,x,a):g) c b'
           return $ (Abs bt x c', Prod bt' x a b')
-        _ -> checkError $ text "function type expected instead of" <+> ppType typ
+        _ -> checkError $ "function type expected instead of" <+> ppType typ
 
     App f a -> do
        over <- getOverload gr g (Just typ) trm
@@ -438,7 +438,7 @@ checkLType gr g trm typ0 = do
       over <- getOverload gr g Nothing trm
       case over of
         Just trty -> return trty
-        _ -> checkError (text "unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
+        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
 
     Q _ -> do
        over <- getOverload gr g (Just typ) trm
@@ -449,7 +449,7 @@ checkLType gr g trm typ0 = do
           termWith trm' $ checkEqLType gr g typ ty' trm'
 
     T _ [] ->
-      checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ)
+      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
     T _ cs -> case typ of 
       Table arg val -> do 
         case allParamValues gr arg of
@@ -458,12 +458,12 @@ checkLType gr g trm typ0 = do
             ps <- testOvershadow ps0 vs
             if null ps 
               then return () 
-              else checkWarn (text "patterns never reached:" $$
+              else checkWarn ("patterns never reached:" $$
                               nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
           _ -> return () -- happens with variable types
         cs' <- mapM (checkCase arg val) cs
         return (T (TTyped arg) cs', typ)
-      _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ)
+      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
     V arg0 vs ->
       case typ of
         Table arg1 val ->
@@ -477,7 +477,7 @@ checkLType gr g trm typ0 = do
          fsts <- mapM (checkM r) rr   -- check that they are found in the record
          return $ (R fsts, typ)       -- normalize record
 
-       _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
+       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
 
     ExtR r s -> case typ of
        _ | typ == typeType -> do
@@ -486,7 +486,7 @@ checkLType gr g trm typ0 = do
            RecType _ -> termWith trm' $ return typeType
            ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType 
                                       -- ext t = t ** ...
-           _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
+           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
 
        RecType rr -> do
 
@@ -496,7 +496,7 @@ checkLType gr g trm typ0 = do
              (s',typ2) <- inferLType gr g s
              case typ2 of
                RecType ss -> return $ map fst ss
-               _ ->  checkError (text "cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
+               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
          let ll1 = [l | (l,_) <- rr, notElem l ll2]
          (r',_) <- checkLType gr g r (RecType [field | field@(l,_) <- rr, elem l ll1])
          (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2])
@@ -509,7 +509,7 @@ checkLType gr g trm typ0 = do
          s' <- justCheck g s ex
          return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
 
-       _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
+       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
 
     FV vs -> do
       ttys <- mapM (flip (checkLType gr g) typ) vs
@@ -524,7 +524,7 @@ checkLType gr g trm typ0 = do
           (arg',val) <- checkLType gr g arg p
           checkEqLType gr g typ t trm
           return (S tab' arg', t)
-        _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty')
+        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
      , do
       (arg',ty) <- inferLType gr g arg
       ty'       <- computeLType gr g ty
@@ -565,9 +565,9 @@ checkLType gr g trm typ0 = do
      _ -> checkError $ 
             if isLockLabel l 
               then let cat = drop 5 (showIdent (label2ident l))
-                   in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> 
-                      text "; try wrapping it with lin" <+> text cat
-              else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
+                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <> 
+                      "; try wrapping it with lin" <+> cat
+              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
 
    checkCase arg val (p,t) = do
      cont <- pattContext gr g arg p
@@ -580,7 +580,7 @@ pattContext env g typ p = case p of
   PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
     t <- lookupResType env (q,c)
     let (cont,v) = typeFormCnc t
-    checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
+    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
               (length cont == length ps)
     checkEqLType env g typ v (patt2term p)
     mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
@@ -591,7 +591,7 @@ pattContext env g typ p = case p of
         let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
         ----- checkWarn $ prt p ++++ show pts ----- debug
         mapM (uncurry (pattContext env g)) pts >>= return . concat
-      _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
+      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
   PT t p' -> do
     checkEqLType env g typ t (patt2term p')
     pattContext env g typ p'
@@ -605,9 +605,9 @@ pattContext env g typ p = case p of
     g2 <- pattContext env g typ q
     let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
     checkCond 
-      (text "incompatible bindings of" <+>
-       fsep (map ppIdent pts) <+> 
-       text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) 
+      ("incompatible bindings of" <+>
+       fsep pts <+> 
+       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) 
     return g1 -- must be g1 == g2
   PSeq p q -> do
     g1 <- pattContext env g typ p
@@ -621,7 +621,7 @@ pattContext env g typ p = case p of
    noBind typ p' = do
     co <- pattContext env g typ p'
     if not (null co)
-      then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) 
+      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p) 
            >> return []
       else return []
 
@@ -630,9 +630,9 @@ checkEqLType gr g t u trm = do
   (b,t',u',s) <- checkIfEqLType gr g t u trm
   case b of
     True  -> return t'
-    False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$
-                          text "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
-                          text "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
+    False -> checkError $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$
+                          "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
+                          "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
 
 checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
 checkIfEqLType gr g t u trm = do
@@ -644,7 +644,7 @@ checkIfEqLType gr g t u trm = do
     --- better: use a flag to forgive? (AR 31/1/2006)
     _ -> case missingLock [] t' u' of
       Ok lo -> do
-        checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo)
+        checkWarn $ "missing lock field" <+> fsep lo
         return (True,t',u',[])
       Bad s -> return (False,t',u',s)
 
@@ -699,7 +699,7 @@ checkIfEqLType gr g t u trm = do
                    not (any (\ (k,b) -> alpha g a b && l == k) ts)]
          (locks,others) = partition isLockLabel ls
        in case others of
-         _:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others)))
+         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
          _ -> return locks
      -- contravariance
      (Prod _ x a b, Prod _ y c d) -> do
@@ -737,9 +737,9 @@ ppType :: Type -> Doc
 ppType ty =
   case ty of
     RecType fs   -> case filter isLockLabel $ map fst fs of
-                      [lock] -> text (drop 5 (showIdent (label2ident lock)))
+                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
                       _      -> ppTerm Unqualified 0 ty
-    Prod _ x a b -> ppType a <+> text "->" <+> ppType b
+    Prod _ x a b -> ppType a <+> "->" <+> ppType b
     _            -> ppTerm Unqualified 0 ty
 
 ppqType :: Type -> Type -> Doc
@@ -750,5 +750,5 @@ ppqType t u = case (ppType t, ppType u) of
 checkLookup :: Ident -> Context -> Check Type
 checkLookup x g =
   case [ty | (b,y,ty) <- g, x == y] of
-    []     -> checkError (text "unknown variable" <+> ppIdent x)
+    []     -> checkError ("unknown variable" <+> x)
     (ty:_) -> return ty
diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs
index 5dd276303..0b90d6f6c 100644
--- a/src/compiler/GF/Compile/TypeCheck/TC.hs
+++ b/src/compiler/GF/Compile/TypeCheck/TC.hs
@@ -28,7 +28,7 @@ import GF.Grammar.Predef
 import Control.Monad
 --import Data.List (sortBy)
 import Data.Maybe
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 data AExp =
      AVr   Ident Val 
@@ -57,7 +57,7 @@ lookupConst :: Theory -> QIdent -> Err Val
 lookupConst th f = th f
 
 lookupVar :: Env -> Ident -> Err Val
-lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((identW,uVal):g)
+lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,uVal):g)
 -- wild card IW: no error produced, ?0 instead.
 
 type TCEnv = (Int,Env,Env)
@@ -129,7 +129,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)
-      _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))
+      _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
 
     Prod _ x a b -> do
       testErr (typ == vType) "expected Type"
@@ -141,11 +141,11 @@ checkExp th tenv@(k,rho,gamma) e ty = do
       case typ of
         VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
                             [] -> return ()
-                            ls -> fail (render (text "no value given for label:" <+> fsep (punctuate comma (map ppLabel ls))))
+                            ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls)))
                           r <- mapM (checkAssign th tenv ys) xs
                           let (xs,css) = unzip r
                           return (AR xs, concat css)
-        _           -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))
+        _           -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "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)
@@ -180,8 +180,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)
-      _ -> 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))
+      _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
+   _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
 
 checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
 checkLabelling th tenv (lbl,typ) = do
@@ -223,7 +223,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
-        _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ))
+        _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
     [] -> do
       (e,cs) <- checkExp th tenv t ty
       return (([],e),cs)
@@ -244,7 +244,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
                     where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
      PImplArg p -> p2t p (ps,i,g,k)
      PTilde t -> (t : ps, i, g, k)
-     _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")
+     _ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch")
 
   upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
 
@@ -282,8 +282,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)
-         _ -> 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))
+         _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
+     _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
 
 -- auxiliaries
 
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 88f44a631..6a7b0e8d1 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -26,7 +26,7 @@ import GF.Data.Operations
 import Data.List
 import qualified Data.Map as Map
 import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 -- | combine a list of definitions into a balanced binary search tree
 buildAnyTree :: Monad m => Ident -> [(Ident,Info)] -> m (BinTree Ident Info)
@@ -37,9 +37,9 @@ buildAnyTree m = go Map.empty
       case Map.lookup c map of
         Just i  -> case unifyAnyInfo m i j of
 		     Ok k  -> go (Map.insert c k map) is
-		     Bad _ -> fail $ render (text "conflicting information in module"<+>ppIdent m $$
+		     Bad _ -> fail $ render ("conflicting information in module"<+>m $$
 		                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                             text "and" $+$
+		                             "and" $+$
 		                             nest 4 (ppJudgement Qualified (c,j)))
         Nothing -> go (Map.insert c j map) is
 
@@ -58,7 +58,7 @@ extendModule cwd gr (name,m)
 
      -- test that the module types match, and find out if the old is complete
      unless (sameMType (mtype m) (mtype mo)) 
-            (checkError (text "illegal extension type to module" <+> ppIdent name))
+            (checkError ("illegal extension type to module" <+> name))
 
      let isCompl = isCompleteModule m0
 
@@ -88,13 +88,13 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
     -- add the information given in interface into an instance module
     Nothing -> do
       unless (null is || mstatus mi == MSIncomplete) 
-             (checkError (text "module" <+> ppIdent i <+> 
-                          text "has open interfaces and must therefore be declared incomplete"))
+             (checkError ("module" <+> i <+> 
+                          "has open interfaces and must therefore be declared incomplete"))
       case mt of
         MTInstance (i0,mincl) -> do
           m1 <- lookupModule gr i0
           unless (isModRes m1)
-                 (checkError (text "interface expected instead of" <+> ppIdent i0))
+                 (checkError ("interface expected instead of" <+> i0))
           js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
           --- to avoid double inclusions, in instance I of I0 = J0 ** ...
           case extends mi of
@@ -112,7 +112,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
       let stat' = ifNull MSComplete (const MSIncomplete)
                     [i | i <- is, notElem i infs]
       unless (stat' == MSComplete || stat == MSIncomplete) 
-             (checkError (text "module" <+> ppIdent i <+> text "remains incomplete"))
+             (checkError ("module" <+> i <+> "remains incomplete"))
       ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
@@ -149,11 +149,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
 		                                 (name,i) <- case i of 
                                                                AnyInd _ m -> lookupOrigInfo gr (m,c)
                                                                _          -> return (name,i)
-		                                 checkError (text "cannot unify the information" $$ 
+		                                 checkError ("cannot unify the information" $$ 
 		                                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                                             text "in module" <+> ppIdent name <+> text "with" $$
+		                                             "in module" <+> name <+> "with" $$
 		                                             nest 4 (ppJudgement Qualified (c,j)) $$
-		                                             text "in module" <+> ppIdent base)
+		                                             "in module" <+> base)
                          Nothing-> if isCompl
                                      then return $ updateTree (c,indirInfo name i) new
                                      else return $ updateTree (c,i) new
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index df60c7c54..816a9f438 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -36,7 +36,7 @@ module GF.Grammar.Grammar (
         PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
         
         Info(..),
-        Location(..), L(..), unLoc, noLoc,
+        Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
         Type,
         Cat,
         Fun,
@@ -63,6 +63,7 @@ module GF.Grammar.Grammar (
 
 import GF.Infra.Ident
 import GF.Infra.Option ---
+import GF.Infra.Location
 
 import GF.Data.Operations
 
@@ -74,7 +75,7 @@ import Data.Array.Unboxed
 import qualified Data.Map as Map
 --import qualified Data.Set as Set
 --import qualified Data.IntMap as IntMap
-import Text.PrettyPrint
+import GF.Text.Pretty
 --import System.FilePath
 --import Control.Monad.Identity
 
@@ -98,6 +99,8 @@ data SourceModInfo = ModInfo {
     jments  :: Map.Map Ident Info
   }
 
+instance HasSourcePath SourceModInfo where sourcePath = msrc
+
 type SourceModule = (Ident, SourceModInfo)
 
 -- | encoding the type of the module
@@ -200,12 +203,12 @@ abstractOfConcrete gr c = do
   n <- lookupModule gr c
   case mtype n of
     MTConcrete a -> return a
-    _ -> raise $ render (text "expected concrete" <+> ppIdent c)
+    _ -> raise $ render ("expected concrete" <+> c)
 
 lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
 lookupModule gr m = case Map.lookup m (moduleMap gr) of
   Just i  -> return i
-  Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
+  Nothing -> raise $ render ("unknown module" <+> m <+> "among" <+> hsep (map fst (modules gr)))
 
 isModAbs :: SourceModInfo -> Bool
 isModAbs m =
@@ -263,7 +266,7 @@ allAbstracts :: SourceGrammar -> [Ident]
 allAbstracts gr = 
  case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
    Left  is     -> is
-   Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
+   Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
 
 -- | the last abstract in dependency order (head of list)
 greatestAbstract :: SourceGrammar -> Maybe Ident
@@ -332,23 +335,6 @@ data Info =
  | AnyInd Bool Ident                         -- ^ (/INDIR/) the 'Bool' says if canonical
   deriving Show
 
-data Location 
-  = NoLoc
-  | Local Int Int
-  | External FilePath Location
-  deriving (Show,Eq,Ord)
-
-data L a = L Location a  -- location information
-  deriving Show
-
-instance Functor L where
-  fmap f (L loc x) = L loc (f x)
-
-unLoc :: L a -> a
-unLoc (L _ x) = x
-
-noLoc = L NoLoc
-
 type Type = Term
 type Cat  = QIdent
 type Fun  = QIdent
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 6bdf87a5c..da75267de 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -42,7 +42,7 @@ import GF.Grammar.Lockfield
 import Data.List (sortBy)
 --import Data.Maybe (maybe)
 --import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
 import qualified Data.Map as Map
 
 -- whether lock fields are added in reuse
@@ -83,7 +83,7 @@ lookupResDefLoc gr (m,c)
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (noLoc (QC (m,c)))
         ResValue _        -> return (noLoc (QC (m,c)))
-        _   -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
+        _   -> raise $ render (c <+> "is not defined in resource" <+> m)
 
 lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
 lookupResType gr (m,c) = do
@@ -99,7 +99,7 @@ lookupResType gr (m,c) = do
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _      -> return typePType
     ResValue (L _ t)  -> return t
-    _   -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
+    _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
 
 lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
 lookupOverload gr (m,c) = do
@@ -112,7 +112,7 @@ lookupOverload gr (m,c) = do
                      concat tss
 
       AnyInd _ n  -> lookupOverload gr (n,c)
-      _   -> raise $ render (ppIdent c <+> text "is not an overloaded operation")
+      _   -> raise $ render (c <+> "is not an overloaded operation")
 
 -- | returns the original 'Info' and the module where it was found
 lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
@@ -132,7 +132,7 @@ lookupParamValues gr c = do
   (_,info) <- lookupOrigInfo gr c
   case info of
     ResParam _ (Just pvs) -> return pvs
-    _                     -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
+    _                     -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
 
 allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
 allParamValues cnc ptyp =
@@ -148,13 +148,13 @@ allParamValues cnc ptyp =
        pvs <- allParamValues cnc pt
        vvs <- allParamValues cnc vt
        return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
-    _ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
+    _ -> raise (render ("cannot find parameter values for" <+> ptyp))
   where
     -- to normalize records and record types
     sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
 
 lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
-lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
+lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
   info <- lookupQIdentInfo gr (m,c)
   case info of
     AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
@@ -168,7 +168,7 @@ lookupLincat gr m c = do
   case info of
     CncCat (Just (L _ t)) _ _ _ _ -> return t
     AnyInd _ n                    -> lookupLincat gr n c
-    _                             -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    _                             -> raise (render (c <+> "has no linearization type in" <+> m))
 
 -- | this is needed at compile time
 lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
@@ -177,7 +177,7 @@ lookupFunType gr m c = do
   case info of
     AbsFun (Just (L _ t)) _ _ _ -> return t
     AnyInd _ n                  -> lookupFunType gr n c
-    _                           -> raise (render (text "cannot find type of" <+> ppIdent c))
+    _                           -> raise (render ("cannot find type of" <+> c))
 
 -- | this is needed at compile time
 lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
@@ -186,7 +186,7 @@ lookupCatContext gr m c = do
   case info of
     AbsCat (Just (L _ co)) -> return co
     AnyInd _ n             -> lookupCatContext gr n c
-    _                      -> raise (render (text "unknown category" <+> ppIdent c))
+    _                      -> raise (render ("unknown category" <+> c))
 
 
 -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index e516f0e47..b623aaa2b 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -31,7 +31,7 @@ import qualified Data.Traversable as T(mapM)
 import Control.Monad (liftM, liftM2, liftM3)
 --import Data.Char (isDigit)
 import Data.List (sortBy,nub)
-import Text.PrettyPrint
+import GF.Text.Pretty
 
 typeForm :: Type -> (Context, Cat, [Term])
 typeForm t =
@@ -45,7 +45,7 @@ typeForm t =
     Q  c -> ([],c,[])
     QC c -> ([],c,[])
     Sort c -> ([],(identW, c),[])
-    _      -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
+    _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
 
 typeFormCnc :: Type -> (Context, Type)
 typeFormCnc t = 
@@ -170,7 +170,7 @@ projectRec :: Label -> [Assign] -> Term
 projectRec l rs =
   case lookup l rs of
     Just (_,t) -> t
-    Nothing    -> error (render (text "no value for label" <+> ppLabel l))
+    Nothing    -> error (render ("no value for label" <+> l))
 
 zipAssign :: [Label] -> [Term] -> [Assign]
 zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
@@ -194,7 +194,7 @@ mkRecType = mkRecTypeN 0
 record2subst :: Term -> Err Substitution
 record2subst t = case t of
   R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
-  _    -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))
+  _    -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))
 
 typeType, typePType, typeStr, typeTok, typeStrs :: Term
 
@@ -273,8 +273,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 -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
-  _ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) 
+      ls -> raise $ render ("clashing labels" <+> hsep ls)
+  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) 
 
 --plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
@@ -283,7 +283,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
-   _ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
+   _ -> raise $ render ("cannot add records" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
 
 -- | default linearization type
 defLinType :: Type
@@ -386,7 +386,7 @@ term2patt trm = case termForm trm of
   Ok ([], Cn c, []) -> do
     return (PMacro c)
 
-  _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
+  _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
 
 patt2term :: Patt -> Term
 patt2term pt = case pt of
@@ -450,7 +450,7 @@ strsFromTerm t = case t of
            ]
   FV ts -> mapM strsFromTerm ts >>= return . concat
   Strs ts -> mapM strsFromTerm ts >>= return . concat  
-  _ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
+  _ -> raise (render ("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
@@ -609,7 +609,7 @@ topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
 topoSortJments (m,mi) = do
   is <- either
           return
-          (\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
+          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
           (topoTest (allDependencies (==m) (jments mi)))
   return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
 
@@ -617,8 +617,8 @@ topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
 topoSortJments2 (m,mi) = do
   iss <- either
            return
-           (\cyc -> raise (render (text "circular definitions:"
-                                   <+> fsep (map ppIdent (head cyc)))))
+           (\cyc -> raise (render ("circular definitions:"
+                                   <+> fsep (head cyc))))
            (topoTest2 (allDependencies (==m) (jments mi)))
   return
     [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs
index 81541b2a3..48cb9bd3f 100644
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -22,20 +22,20 @@ import GF.Data.Operations
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Grammar.Macros
-import GF.Grammar.Printer
+--import GF.Grammar.Printer
 
 --import Data.List
 import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
 --import Debug.Trace
 
 matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
 matchPattern pts term = 
   if not (isInConstantForm term)
-    then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
+    then raise (render ("variables occur in" <+> pp term))
   else do
     term' <- mkK term
-    errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
+    errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
       findMatch [([p],t) | (p,t) <- pts] [term']
  where
   -- to capture all Str with string pattern matching
@@ -49,7 +49,7 @@ matchPattern pts term =
     K w -> return [w]
     C v w -> liftM2 (++) (getS v) (getS w)
     Empty -> return []
-    _ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
+    _ -> raise (render ("cannot get string from" <+> s))
 
 testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
 testOvershadow pts vs = do
@@ -60,10 +60,10 @@ testOvershadow pts vs = do
 
 findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
 findMatch cases terms = case cases of
-   [] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
+   [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
    (patts,_):_ | length patts /= length terms -> 
-       raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> 
-                    text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
+       raise (render ("wrong number of args for patterns :" <+> hsep patts <+> 
+                    "cannot take" <+> hsep terms))
    (patts,val):cc -> case mapM tryMatch (zip patts terms) of
        Ok substs -> return (val, concat substs)
        _         -> findMatch cc terms
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
 
       (PNeg p',_) -> case tryMatch (p',t) of
         Bad _ -> return []
-        _ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
+        _ -> raise (render ("no match with negative pattern" <+> p))
 
       (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
       (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
       (PChar,  ([],K [_], [])) -> return []
       (PChars cs, ([],K [c], [])) | elem c cs -> return []
 
-      _ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
+      _ -> raise (render ("no match in case expr for" <+> t))
 
 matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
 --matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 6138f2ab9..da29e3ebd 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -9,8 +9,6 @@
 
 module GF.Grammar.Printer
            ( TermPrintQual(..)
-           , ppLabel
-           , ppGrammar
            , ppModule
            , ppJudgement
            , ppParams
@@ -18,7 +16,6 @@ module GF.Grammar.Printer
            , ppPatt
            , ppValue
            , ppConstrs
-           , ppLocation
            , ppQIdent
            , ppMeta
            , getAbs
@@ -31,7 +28,7 @@ import GF.Grammar.Grammar
 
 import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
 
-import Text.PrettyPrint
+import GF.Text.Pretty
 import Data.Maybe (isNothing)
 import Data.List  (intersperse)
 import qualified Data.Map as Map
@@ -43,8 +40,8 @@ data TermPrintQual
   = Unqualified | Qualified | Internal
   deriving Eq                 
 
-ppGrammar :: SourceGrammar -> Doc
-ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
+instance Pretty SourceGrammar where
+  pp = vcat . map (ppModule Qualified) . modules
 
 ppModule :: TermPrintQual -> SourceModule -> Doc
 ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
@@ -54,288 +51,286 @@ ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
             maybe empty (ppSequences q) mseqs) $$
     ftr
     where
-      hdr = complModDoc <+> modTypeDoc <+> equals <+> 
-            hsep (intersperse (text "**") $
+      hdr = complModDoc <+> modTypeDoc <+> '=' <+> 
+            hsep (intersperse (pp "**") $
                   filter (not . isEmpty)  $ [ commaPunct ppExtends exts
                                             , maybe empty ppWith with
                                             , if null opens
-                                                then lbrace
-                                                else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace
+                                                then pp '{'
+                                                else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
                                             ])
 
-      ftr = rbrace
+      ftr = '}'
 
       complModDoc =
         case mstat of
           MSComplete   -> empty
-          MSIncomplete -> text "incomplete"
+          MSIncomplete -> pp "incomplete"
 
       modTypeDoc =
         case mtype of
-          MTAbstract         -> text "abstract"  <+> ppIdent mn
-          MTResource         -> text "resource"  <+> ppIdent mn
-          MTConcrete abs     -> text "concrete"  <+> ppIdent mn <+> text "of" <+> ppIdent abs
-          MTInterface        -> text "interface" <+> ppIdent mn
-          MTInstance ie      -> text "instance"  <+> ppIdent mn <+> text "of" <+> ppExtends ie
+          MTAbstract         -> "abstract"  <+> mn
+          MTResource         -> "resource"  <+> mn
+          MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs
+          MTInterface        -> "interface" <+> mn
+          MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie
 
-      ppExtends (id,MIAll        ) = ppIdent id
-      ppExtends (id,MIOnly   incs) = ppIdent id              <+> brackets (commaPunct ppIdent incs)
-      ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)
+      ppExtends (id,MIAll        ) = pp id
+      ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)
+      ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
       
-      ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens
+      ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
 
 ppOptions opts = 
-  text "flags" $$
-  nest 2 (vcat [text option <+> equals <+> ppLit value <+> semi | (option,value) <- optionsGFO opts])
+  "flags" $$
+  nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
 
 ppJudgement q (id, AbsCat pcont ) =
-  text "cat" <+> ppIdent id <+>
+  "cat" <+> id <+>
   (case pcont of
      Just (L _ cont) -> hsep (map (ppDecl q) cont)
-     Nothing         -> empty) <+> semi
+     Nothing         -> empty) <+> ';'
 ppJudgement q (id, AbsFun ptype _ pexp poper) =
   let kind | isNothing pexp      = "data"
            | poper == Just False = "oper"
            | otherwise           = "fun"
   in
   (case ptype of
-     Just (L _ typ) -> text kind <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
+     Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
      Nothing        -> empty) $$
   (case pexp of
      Just []  -> empty
-     Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs]
+     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
      Nothing  -> empty)
 ppJudgement q (id, ResParam pparams _) = 
-  text "param" <+> ppIdent id <+>
+  "param" <+> id <+>
   (case pparams of
-     Just (L _ ps) -> equals <+> ppParams q ps
-     _             -> empty) <+> semi
+     Just (L _ ps) -> '=' <+> ppParams q ps
+     _             -> empty) <+> ';'
 ppJudgement q (id, ResValue pvalue) = 
-  text "-- param constructor" <+> ppIdent id <+> colon <+> 
+  "-- param constructor" <+> id <+> ':' <+> 
   (case pvalue of
-     (L _ ty) -> ppTerm q 0 ty) <+> semi
+     (L _ ty) -> ppTerm q 0 ty) <+> ';'
 ppJudgement q (id, ResOper  ptype pexp) =
-  text "oper" <+> ppIdent id <+>
-  (case ptype of {Just (L _ t) -> colon  <+> ppTerm q 0 t; Nothing -> empty} $$
-   case pexp  of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
+  "oper" <+> id <+>
+  (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
+   case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
 ppJudgement q (id, ResOverload ids defs) =
-  text "oper" <+> ppIdent id <+> equals <+> 
-  (text "overload" <+> lbrace $$
-   nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
-   rbrace) <+> semi
+  "oper" <+> id <+> '=' <+> 
+  ("overload" <+> '{' $$
+   nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
+   '}') <+> ';'
 ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
   (case pcat of
-     Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
+     Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
      Nothing        -> empty) $$
   (case pdef of
-     Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
+     Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
      Nothing        -> empty) $$
   (case pref of
-     Just (L _ exp) -> text "linref" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
+     Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
      Nothing        -> empty) $$
   (case pprn of
-     Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
   (case (mpmcfg,q) of
      (Just (PMCFG prods funs),Internal)
-                    -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
                        nest 2 (vcat (map ppProduction prods) $$
-                               space $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> 
-                                                          parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> 
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
                                          (Array.assocs funs))) $$
-                       char '}'
+                       '}'
      _              -> empty)
 ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
   (case pdef of
      Just (L _ e) -> let (xs,e') = getAbs e
-                     in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
+                     in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
      Nothing      -> empty) $$
   (case pprn of
-     Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
   (case (mpmcfg,q) of
      (Just (PMCFG prods funs),Internal)
-                    -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
                        nest 2 (vcat (map ppProduction prods) $$
-                               space $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> 
-                                                          parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> 
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
                                          (Array.assocs funs))) $$
-                       char '}'
+                       '}'
      _              -> 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
+    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
+instance Pretty Term where pp = ppTerm Unqualified 0
+
 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')
+                           in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> 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
+                           ([],_) -> "table" <+> '{' $$
+	  		             nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+			             '}'
+                           (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
+ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+			       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+			       '}'
+ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+		 	       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+			       '}'
+ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+			       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+			       '}'
 ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
-                              then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b)
-                              else prec d 0 (parens (ppBind (bt,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)
+                              then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
+                              else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
+ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> 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 (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s)
-ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 (text "++" <+> ppTerm q 1 e2))
-ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+'  <+> ppTerm q 2 e2)
+                          in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
+ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
+ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
+ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)
 ppTerm q d (S x y)     = case x of
                            T annot xs -> let e = case annot of
 			                           TRaw     -> y
 			                           TTyped t -> Typed y t
 			                           TComp  t -> Typed y t
 			                           TWild  t -> Typed y t
-			                 in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$
-			                    nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
-			                   rbrace
-			   _          -> prec d 3 (hang (ppTerm q 3 x) 2 (text "!" <+> ppTerm q 4 y))
-ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y)
+			                 in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
+			                    nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+			                   '}'
+			   _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
+ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> 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)    = hang (text "table") 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate semi (map (ppTerm q 0) es)))])
-ppTerm q d (FV es)     = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (AdHocOverload es)     = text "overload" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (Alts e xs) = prec d 4 (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 (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
+ppTerm q d (FV es)     = "variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
+ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
+ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
+ppTerm q d (Cn id)     = pp id
+ppTerm q d (Vr id)     = pp id
 ppTerm q d (Q  id)     = ppQIdent q id
 ppTerm q d (QC id)     = ppQIdent q id
-ppTerm q d (Sort id)   = ppIdent id
+ppTerm q d (Sort id)   = pp id
 ppTerm q d (K s)       = str s
-ppTerm q d (EInt n)    = int n
-ppTerm q d (EFloat f)  = double f
+ppTerm q d (EInt n)    = pp n
+ppTerm q d (EFloat f)  = pp f
 ppTerm q d (Meta i)    = ppMeta i
-ppTerm q d (Empty)     = text "[]"
-ppTerm q d (R [])      = text "<>" -- to distinguish from {} empty RecType
-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 '>'
+ppTerm q d (Empty)     = pp "[]"
+ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
+ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+> 
+                                                       fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
+                                                             '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
+ppTerm q d (RecType xs)= braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
-ppTerm q d (ELincat cat t) = prec d 4 (text "lincat" <+> ppIdent cat <+> ppTerm q 5 t)
-ppTerm q d (ELin cat t) = prec d 4 (text "lin" <+> ppIdent cat <+> ppTerm q 5 t)
-ppTerm q d (Error s)   = prec d 4 (text "Predef.error" <+> str s)
+ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
 
-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e
+ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
-ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> 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 (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
+instance Pretty Patt where pp = ppPatt Unqualified 0
+
+ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
 ppPatt q d (PC f ps)    = if null ps
-                            then ppIdent f
-                            else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 3) ps))
+                            then pp f
+                            else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
 ppPatt q d (PP f ps)    = if null ps
                             then ppQIdent q f
                             else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> char '*')
-ppPatt q d (PAs f p)    = prec d 2 (ppIdent f <> char '@' <> ppPatt q 3 p)
-ppPatt q d (PNeg p)     = prec d 2 (char '-' <> ppPatt q 3 p)
-ppPatt q d (PChar)      = char '?'
+ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
+ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
+ppPatt q d (PChar)      = pp '?'
 ppPatt q d (PChars s)   = brackets (str s)
-ppPatt q d (PMacro id)  = char '#' <> ppIdent id
-ppPatt q d (PM id)      = char '#' <> ppQIdent q id
-ppPatt q d PW           = char '_'
-ppPatt q d (PV id)      = ppIdent id
-ppPatt q d (PInt n)     = int n
-ppPatt q d (PFloat f)   = double f
+ppPatt q d (PMacro id)  = '#' <> id
+ppPatt q d (PM id)      = '#' <> ppQIdent q id
+ppPatt q d PW           = pp '_'
+ppPatt q d (PV id)      = pp id
+ppPatt q d (PInt n)     = pp n
+ppPatt q d (PFloat f)   = pp 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]))
+ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
 ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
-ppPatt q d (PTilde t)   = prec d 2 (char '~' <> ppTerm q 6 t)
+ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
 
 ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x)    = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
+ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- 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 (VCn (_,c))   = pp 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"
+ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
+ppValue q d VType         = pp "Type"
 
 ppConstrs :: Constraints -> [Doc]
-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
 
 ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
+ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
 
-str s = doubleQuotes (text s)
+str s = doubleQuotes s
 
 ppDecl q (_,id,typ)
   | id == identW = ppTerm q 3 typ
-  | otherwise    = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
 
 ppDDecl q (_,id,typ)
   | id == identW = ppTerm q 6 typ
-  | otherwise    = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
 
+ppQIdent :: TermPrintQual -> QIdent -> Doc
 ppQIdent q (m,id) =
   case q of
-    Unqualified ->                          ppIdent id
-    Qualified   -> ppIdent m <> char '.' <> ppIdent id
-    Internal    -> ppIdent m <> char '.' <> ppIdent id
+    Unqualified ->          pp id
+    Qualified   -> m <> '.' <> id
+    Internal    -> m <> '.' <> id
     
 
-ppLabel = ppIdent . label2ident
+instance Pretty Label where pp = pp . label2ident
 
-ppOpenSpec (OSimple id)   = ppIdent id
-ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
+ppOpenSpec (OSimple id)   = pp id
+ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
 
-ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)
+ppInstSpec (id,n) = parens (id <+> '=' <+> n)
 
 ppLocDef q (id, (mbt, e)) =
-  ppIdent id <+>
-  (case mbt of {Just t -> colon  <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi
+  id <+>
+  (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
 
-ppBind (Explicit,v) = ppIdent v
-ppBind (Implicit,v) = braces (ppIdent v)
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
 
-ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 
-ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
-
-ppLocation :: FilePath -> Location -> Doc
-ppLocation fpath NoLoc          = text fpath
-ppLocation fpath (External p l) = ppLocation p l
-ppLocation fpath (Local b e)
-  | b == e    = text fpath <> colon <> int b
-  | otherwise = text fpath <> colon <> int b <> text "-" <> int e
+ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
+ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 
 ppProduction (Production fid funid args) =
-  ppFId fid <+> text "->" <+> ppFunId funid <> 
-  brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))
+  ppFId fid <+> "->" <+> ppFunId funid <> 
+  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
 
 ppSequences q seqsArr
   | null seqs || q /= Internal = empty
-  | otherwise                  = text "sequences" <+> char '{' $$
+  | otherwise                  = "sequences" <+> '{' $$
                                  nest 2 (vcat (map ppSeq seqs)) $$
-                                 char '}'
+                                 '}'
   where
     seqs = Array.assocs seqsArr
 
-commaPunct f ds = (hcat (punctuate comma (map f ds)))
+commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc
   | d1 > d2   = parens doc
diff --git a/src/compiler/GF/Grammar/ShowTerm.hs b/src/compiler/GF/Grammar/ShowTerm.hs
index 8f64fbc5a..d97ad9fe3 100644
--- a/src/compiler/GF/Grammar/ShowTerm.hs
+++ b/src/compiler/GF/Grammar/ShowTerm.hs
@@ -5,7 +5,7 @@ import GF.Grammar.Printer
 import GF.Grammar.Lookup
 import GF.Data.Operations
 
-import Text.PrettyPrint
+import GF.Text.Pretty
 import Data.List  (intersperse)
 
 showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
@@ -13,7 +13,7 @@ showTerm gr sty q t = case sty of
     TermPrintTable -> render $ vcat [p <+> s | (p,s) <- ppTermTabular gr q t]
     TermPrintAll   -> render $ vcat [      s | (p,s) <- ppTermTabular gr q t]
     TermPrintList  -> renderStyle (style{mode = OneLineMode}) $ 
-      vcat (punctuate comma [s | (p,s) <- ppTermTabular gr q t])
+      vcat (punctuate ',' [s | (p,s) <- ppTermTabular gr q t])
     TermPrintOne   -> render $ vcat [      s | (p,s) <- take 1 (ppTermTabular gr q t)]
     TermPrintDefault -> render $ ppTerm q 0 t
 
@@ -21,19 +21,19 @@ 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]
+      [(lab       <+> '.' <+> 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]
+      [(ppPatt q 0 patt     <+> "=>" <+> 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]
+      in [(ppTerm q 0 pval <+> "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
     _      -> [(empty,ps t)]
   ps t = case t of
-    K s   -> text s
+    K s   -> pp s
     C s u -> ps s <+> ps u
-    FV ts -> hsep (intersperse (char '/') (map ps ts))
+    FV ts -> hsep (intersperse (pp '/') (map ps ts))
     _     -> ppTerm q 0 t
 
 data TermPrintStyle
diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs
index 045ba4852..24fbc3644 100644
--- a/src/compiler/GF/Infra/CheckM.hs
+++ b/src/compiler/GF/Infra/CheckM.hs
@@ -21,11 +21,11 @@ module GF.Infra.CheckM
 
 import GF.Data.Operations
 --import GF.Infra.Ident
-import GF.Grammar.Grammar(msrc) -- ,Context
-import GF.Grammar.Printer(ppLocation)
+--import GF.Grammar.Grammar(msrc) -- ,Context
+import GF.Infra.Location(ppLocation,sourcePath)
 
 import qualified Data.Map as Map
-import Text.PrettyPrint
+import GF.Text.Pretty
 import System.FilePath(makeRelative)
 import Control.Parallel.Strategies(parList,rseq,using)
 import Control.Monad(liftM)
@@ -51,7 +51,7 @@ instance Monad Check where
                  (ws,Fail msg)  -> (ws,Fail msg)
 
 instance ErrorMonad Check where
-  raise s = checkError (text s)
+  raise s = checkError (pp s)
   handle f h = handle' f (h . render)
 
 handle' f h = Check (\{-ctxt-} msgs -> case unCheck f {-ctxt-} msgs of
@@ -67,7 +67,7 @@ checkCond s b = if b then return () else checkError s
 
 -- | warnings should be reversed in the end
 checkWarn :: Message -> Check ()
-checkWarn msg = Check $ \{-ctxt-} (es,ws) -> ((es,(text "Warning:" <+> msg) : ws),Success ())
+checkWarn msg = Check $ \{-ctxt-} (es,ws) -> ((es,("Warning:" <+> msg) : ws),Success ())
 
 checkWarnings = mapM_ checkWarn
 
@@ -151,6 +151,6 @@ checkIn msg c = Check $ \{-ctxt-} msgs0 ->
 -- | Augment error messages with a relative path to the source module and
 -- an contextual hint (which can be left 'empty')
 checkInModule cwd mi loc context =
-    checkIn (ppLocation relpath loc <> colon $$ nest 2 context)
+    checkIn (ppLocation relpath loc <> ':' $$ nest 2 context)
   where
-    relpath = makeRelative cwd (msrc mi)
+    relpath = makeRelative cwd (sourcePath mi)
diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs
index 390c5ba84..272efca03 100644
--- a/src/compiler/GF/Infra/Ident.hs
+++ b/src/compiler/GF/Infra/Ident.hs
@@ -13,7 +13,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- * Identifiers
-	      Ident, ident2utf8, showIdent, ppIdent, prefixIdent,
+	      Ident, ident2utf8, showIdent, prefixIdent,
 	      identS, identC, identV, identA, identAV, identW,
 	      argIdent, isArgIdent, getArgIndex,
               varStr, varX, isWildIdent, varIndex,
@@ -31,7 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
                  -- UTF-8-encoded bytestrings!
 import Data.Char(isDigit)
 import PGF.Internal(Binary(..))
-import Text.PrettyPrint(Doc,text)
+import GF.Text.Pretty
 
 
 -- | the constructors labelled /INTERNAL/ are
@@ -81,8 +81,7 @@ ident2raw = Id . ident2utf8
 showIdent :: Ident -> String
 showIdent i = unpack $! ident2utf8 i
 
-ppIdent :: Ident -> Doc
-ppIdent = text . showIdent
+instance Pretty Ident where pp = pp . showIdent
 
 identS :: String -> Ident
 identS = identC . rawIdentS
diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs
index fe1d01423..aa0c7d7ff 100644
--- a/src/compiler/GF/Infra/UseIO.hs
+++ b/src/compiler/GF/Infra/UseIO.hs
@@ -54,7 +54,7 @@ errOptIO os e m = case m of
     return e
 -}
 type FileName = String
-type InitPath = String
+type InitPath = String -- ^ the directory portion of a pathname
 type FullPath = String
 
 gfLibraryPath    = "GF_LIB_PATH"
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index 4d7e65870..44f978cb3 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -42,7 +42,7 @@ import qualified Text.ParserCombinators.ReadP as RP
 import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
 import Control.Exception(SomeException,fromException,evaluate,try)
 import Control.Monad
-import Text.PrettyPrint (render)
+import GF.Text.Pretty (render)
 import qualified GF.System.Signal as IO(runInterruptibly)
 #ifdef SERVER_MODE
 import GFServer(server)
@@ -247,7 +247,7 @@ execute1 opts gfenv0 s0 =
                  (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in 
                     restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file))
                  (modules mygr)  
-        _ -> putStrLn $ render $ ppGrammar mygr
+        _ -> putStrLn $ render mygr
       continue gfenv
 
     dependency_graph ws =
diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs
index 0f07bc8bf..c0f7e3946 100644
--- a/src/compiler/SimpleEditor/Convert.hs
+++ b/src/compiler/SimpleEditor/Convert.hs
@@ -6,7 +6,7 @@ import Data.List(sortBy)
 import Data.Function(on)
 import qualified Data.Map as Map
 import Text.JSON(makeObj) --encode
-import Text.PrettyPrint(render,text,(<+>))
+import GF.Text.Pretty(render,(<+>))
 
 import qualified Data.ByteString.UTF8 as UTF8(fromString)
 
@@ -124,11 +124,11 @@ convCncJment (name,jment) =
     ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
       where
         lhs = i++maybe "" ((" : "++) . render . ppTerm q 0 . unLoc) oltyp
-        rhs = render (text " ="<+>ppTerm q 0 (unLoc lterm))
+        rhs = render (" ="<+>ppTerm q 0 (unLoc lterm))
     ResOverload [] defs -> return $ Op $ Oper lhs rhs
       where
         lhs = i
-        rhs = render $ text " = overload"<+>ppTerm q 0 r
+        rhs = render $ " = overload"<+>ppTerm q 0 r
         r =  R [(lab,(Just ty,fu)) | (L _ ty,L _ fu) <-defs]
         lab = ident2label name
     CncFun _ (Just ldef) pprn _ -> -- ignores printname !!