summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Compile')
-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
9 files changed, 175 insertions, 180 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:50:51 +0000