summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Command/Commands.hs28
-rw-r--r--src/compiler/GF/Compile.hs36
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs35
-rw-r--r--src/compiler/GF/Compile/Compute/ConcreteNew.hs34
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs42
-rw-r--r--src/compiler/GF/Compile/Optimize.hs14
-rw-r--r--src/compiler/GF/Compile/Rename.hs30
-rw-r--r--src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs42
-rw-r--r--src/compiler/GF/Compile/TypeCheck/RConcrete.hs114
-rw-r--r--src/compiler/GF/Compile/TypeCheck/TC.hs22
-rw-r--r--src/compiler/GF/Compile/Update.hs22
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs30
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs20
-rw-r--r--src/compiler/GF/Grammar/Macros.hs24
-rw-r--r--src/compiler/GF/Grammar/PatternMatch.hs20
-rw-r--r--src/compiler/GF/Grammar/Printer.hs315
-rw-r--r--src/compiler/GF/Grammar/ShowTerm.hs14
-rw-r--r--src/compiler/GF/Infra/CheckM.hs14
-rw-r--r--src/compiler/GF/Infra/Ident.hs7
-rw-r--r--src/compiler/GF/Infra/UseIO.hs2
20 files changed, 418 insertions, 447 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
-
- 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)
+ 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 ) = 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) <+> "->" <+> ppTerm q 0 e
-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
-ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e
+instance Pretty Patt where pp = ppPatt Unqualified 0
-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)
+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
-
-ppBind (Explicit,v) = ppIdent v
-ppBind (Implicit,v) = braces (ppIdent v)
+ id <+>
+ (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
-ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
-ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
-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"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 18:22:42 +0000