From 9cebd25eacc7662bd35a9e098befb1edc6ba711c Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 14 Sep 2009 15:13:11 +0000 Subject: [PATCH] Use GF.Grammar.Printer everywhere instead of PrGrammar --- src/GF/Compile/AbsCompute.hs | 23 ++++++++------- src/GF/Compile/CheckGrammar.hs | 2 +- src/GF/Compile/Compute.hs | 30 +++++++++---------- src/GF/Compile/GrammarToGFCC.hs | 50 +++++++++++++++---------------- src/GF/Compile/ModDeps.hs | 2 +- src/GF/Compile/Optimize.hs | 33 +++++++++------------ src/GF/Compile/OptimizeGF.hs | 3 +- src/GF/Compile/Rename.hs | 26 ++++++++--------- src/GF/Compile/TC.hs | 18 ++++++------ src/GF/Compile/TypeCheck.hs | 12 ++++---- src/GF/Grammar/Abstract.hs | 4 +-- src/GF/Grammar/AppPredefined.hs | 17 ++++++----- src/GF/Grammar/Lockfield.hs | 3 +- src/GF/Grammar/Lookup.hs | 52 ++++++++++++++++++--------------- src/GF/Grammar/MMacros.hs | 8 +++-- src/GF/Grammar/Macros.hs | 28 +++++++++--------- src/GF/Grammar/PatternMatch.hs | 20 ++++++------- src/GF/Grammar/Printer.hs | 19 ++++++++++++ src/GF/Grammar/Unify.hs | 8 ++--- 19 files changed, 189 insertions(+), 169 deletions(-) diff --git a/src/GF/Compile/AbsCompute.hs b/src/GF/Compile/AbsCompute.hs index 918682ecc..f08313895 100644 --- a/src/GF/Compile/AbsCompute.hs +++ b/src/GF/Compile/AbsCompute.hs @@ -30,6 +30,7 @@ import GF.Compile.Compute import Debug.Trace import Data.List(intersperse) import Control.Monad (liftM, liftM2) +import Text.PrettyPrint -- for debugging tracd m t = t @@ -45,7 +46,7 @@ computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp -computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where +computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where compt vv t = case t of -- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) -- Abs x b -> liftM (Abs x) (compt (x:vv) b) @@ -55,21 +56,21 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where let vv' = yy ++ vv aa' <- mapM (compt vv') aa case look f of - Just eqs -> tracd ("\nmatching" +++ prt f) $ + Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $ case findMatch eqs aa' of Ok (d,g) -> do --- let (xs,ts) = unzip g --- ts' <- alphaFreshAll vv' ts let g' = g --- zip xs ts' d' <- compt vv' $ substTerm vv' g' d - tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' - _ -> tracd ("no match" +++ prt t') $ + tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d' + _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ do let v = mkApp f aa' return $ mkAbs yy $ v _ -> do let t2 = mkAbs yy $ mkApp f aa' - tracd ("not defined" +++ prt_ t2) $ return t2 + tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2 look t = case t of (Q m f) -> case lookd m f of @@ -93,12 +94,12 @@ beta vv c = case c of findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) findMatch cases terms = case cases of - [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms))) (patts,_):_ | length patts /= length terms -> - Bad ("wrong number of args for patterns :" +++ - unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) + Bad (render (text "wrong number of args for patterns :" <+> + hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs) + Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs) _ -> findMatch cc terms tryMatch :: (Patt, Term) -> Err [(Ident, Term)] @@ -127,7 +128,7 @@ tryMatch (p,t) = do (PAs x p',_) -> do subst <- trym p' t' return $ (x,t) : subst - _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t) + _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t)) notMeta e = case e of Meta _ -> False @@ -136,4 +137,4 @@ tryMatch (p,t) = do _ -> True prtm p g = - prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g] + ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g]) diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 1b1b80af3..d5f464a0c 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -129,7 +129,7 @@ checkAbsInfo st m mo c info = do where mkCheck cat ss = case ss of [] -> return info - _ -> checkError (vcat (map text ss) $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c) + _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c) compAbsTyp g t = case t of Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g diff --git a/src/GF/Compile/Compute.hs b/src/GF/Compile/Compute.hs index 062b6251c..f764acc52 100644 --- a/src/GF/Compile/Compute.hs +++ b/src/GF/Compile/Compute.hs @@ -18,9 +18,9 @@ import GF.Data.Operations import GF.Grammar.Grammar import GF.Infra.Ident import GF.Infra.Option -import GF.Data.Str -import GF.Grammar.PrGrammar import GF.Infra.Modules +import GF.Data.Str +import GF.Grammar.Printer import GF.Grammar.Predef import GF.Grammar.Macros import GF.Grammar.Lookup @@ -32,8 +32,7 @@ import GF.Grammar.AppPredefined import Data.List (nub,intersperse) import Control.Monad (liftM2, liftM) - ----- import Debug.Trace ---- +import Text.PrettyPrint -- | computation of concrete syntax terms into normal form -- used mainly for partial evaluation @@ -57,7 +56,7 @@ computeTermOpt rec gr = comput True where | otherwise -> look p c Vr x -> do - t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g + t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g case t' of _ | t == t' -> return t _ -> comp g t' @@ -113,7 +112,7 @@ computeTermOpt rec gr = comput True where t' <- comp g t case t' of FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants - R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ + R r -> maybe (Bad (render (text "no value for label" <+> ppLabel l))) (comp g . snd) $ lookup l $ reverse r ExtR a (R b) -> @@ -275,7 +274,7 @@ computeTermOpt rec gr = comput True where compPatternMacro p = case p of PM m c -> case look m c of Ok (EPatt p') -> compPatternMacro p' - _ -> prtBad "pattern expected as value of" p ---- should be in CheckGr + _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p))) PAs x p -> do p' <- compPatternMacro p return $ PAs x p' @@ -325,7 +324,7 @@ computeTermOpt rec gr = comput True where _ -> v' case matchPattern cc v2 of Ok (c,g') -> comp (g' ++ g) c - _ | isCan v2 -> prtBad ("missing case" +++ prt v2 +++ "in") t + _ | isCan v2 -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v2 <+> text "in" <+> ppTerm Unqualified 0 t)) _ -> return $ S t' v' -- if v' is not canonical S (T i cs) e -> prawitz g i (flip S v') cs e @@ -422,7 +421,7 @@ computeTermOpt rec gr = comput True where as <- getPatts a bs <- getPatts b return [K (s ++ t) | K s <- as, K t <- bs] - _ -> fail $ "not valid pattern in pre expression" +++ prt p + _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) {- ---- uncurrySelect g fs t v = do @@ -450,18 +449,15 @@ computeTermOpt rec gr = comput True where -- | argument variables cannot be glued checkNoArgVars :: Term -> Err Term checkNoArgVars t = case t of - Vr (IA _ _) -> Bad $ glueErrorMsg $ prt t - Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t + Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t + Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t _ -> composOp checkNoArgVars t glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." + render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$ + text "Use Prelude.bind instead.") getArgType t = case t of V ty _ -> return ty T (TComp ty) _ -> return ty - _ -> prtBad "cannot get argument type of table" t - - - + _ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t))) diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 881166695..df9203f4f 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -11,7 +11,7 @@ import qualified PGF.Macros as CM import qualified PGF.Data as C import qualified PGF.Data as D import GF.Grammar.Predef -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look import qualified GF.Grammar.Abstract as A @@ -28,6 +28,7 @@ import Data.List import Data.Char (isDigit,isSpace) import qualified Data.Map as Map import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint import Debug.Trace ---- -- when developing, swap commenting @@ -60,7 +61,7 @@ addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toL canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = - (if dump opts DumpCanon then trace (prGrammar cgr) else id) $ + (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $ D.PGF an cns gflags abs cncs where -- abstract @@ -181,7 +182,7 @@ mkTerm tr = case tr of Abs _ t -> mkTerm t ---- only on toplevel Alts (td,tvs) -> C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging + _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging where mkLab (LIdent l) = case BS.unpack l of '_':ds -> (read ds) :: Int @@ -218,7 +219,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do mkPType typ = case typ of RecType lts -> do ts <- mapM (mkPType . snd) lts - return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts] + return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts] Table (RecType lts) v -> do ps <- mapM (mkPType . snd) lts v' <- mkPType v @@ -229,7 +230,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do return $ C.S [p',v'] Sort s | s == cStr -> return $ C.S [] _ -> return $ - C.FV $ map (kks . filter showable . prt_) $ + C.FV $ map (kks . filter showable . render . ppTerm Qualified 0) $ errVal [] $ Look.allParamValues sgr typ showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records kks = C.K . C.KS @@ -275,7 +276,7 @@ repartition abs cg = [] -> [abs] -- to make pgf nonempty even when there are no concretes cncs -> cncs, let mo = errVal - (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang + (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang ] -- translate tables and records to arrays, parameters and labels to indices @@ -292,7 +293,7 @@ canon2canon opts abs cg0 = c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) j2j cg (f,j) = - let debug = if verbAtLeast opts Verbose then trace ("+ " ++ prt f) else id in + let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in case j of CncFun x (Just tr) z -> CncFun x (Just (debug (t2t tr))) z CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t x)) y @@ -313,23 +314,22 @@ canon2canon opts abs cg0 = _ -> [(x,ty)] ---- - trs v = traceD (tr v) v + trs v = traceD (render (tr v)) v tr (labels,untyps,typs) = - ("LABELS:" ++++ - unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | - ((c,l),i) <- Map.toList labels]) ++++ - ("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) ++++ - ("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) | - (t,i) <- Map.toList typs]) + (text "LABELS:" <+> + vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$ + (text "UNTYPS:" <+> + vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$ + (text "TYPS: " <+> + vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs]) ---- purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar purgeGrammar abstr gr = (M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr where - list ms = traceD ("MODULES" +++ unwords (map (prt . fst) ms)) ms + list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) needed = nub $ concatMap (requiredCanModules isSingle gr) acncs acncs = abstr : M.allConcretes gr abstr @@ -384,7 +384,7 @@ paramValues cgr = (labels,untyps,typs) where updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr _ -> GM.composOp typsFromTrm tr - mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.modules cgr + mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr jments = [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] @@ -435,7 +435,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of P t l -> r2r tr PI t l i -> EInt $ toInteger i - T (TWild _) _ -> error $ "wild" +++ prt tr + T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr)) T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc V ty ts -> mkCurry $ V ty [t2t t | t <- ts] @@ -468,8 +468,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of Just vs -> (ty,[t | (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) (Map.assocs vs)]) - _ -> error $ "doVar1" +++ A.prt ty - _ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug + _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty) + _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug updateSTM ((tyvs, (tr', tr)):) return tr' _ -> GM.composOp doVar tr @@ -480,7 +480,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ Map.lookup (cat,labs) labels - _ -> K ((A.prt tr +++ prtTrace tr "66665")) + _ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665))) -- this goes recursively into tables (ignored) and records (accumulated) getLab tr = case tr of @@ -511,8 +511,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of (FV ts,_) -> ts _ -> [tr] valNumFV ts = case ts of - [tr] -> let msg = ("DEBUG" +++ prt fun ++ ": error in valNum" +++ prt tr) in - trace msg $ error (prt fun) + [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in + trace msg $ error (showIdent fun) _ -> FV $ map valNum ts mkCurry trm = case trm of @@ -553,8 +553,8 @@ unlockTy ty = case ty of prtTrace tr n = - trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n -prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n + trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n +prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n -- | this function finds out what modules are really needed in the canonical gr. diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs index 8bfead11b..812c8163f 100644 --- a/src/GF/Compile/ModDeps.hs +++ b/src/GF/Compile/ModDeps.hs @@ -23,7 +23,7 @@ module GF.Compile.ModDeps (mkSourceGrammar, import GF.Grammar.Grammar import GF.Infra.Ident import GF.Infra.Option -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import GF.Compile.Update import GF.Grammar.Lookup import GF.Infra.Modules diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index 7f6e451c7..9122b6e5f 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -18,7 +18,7 @@ module GF.Compile.Optimize (optimizeModule) where import GF.Grammar.Grammar import GF.Infra.Ident import GF.Infra.Modules -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import GF.Grammar.Macros import GF.Grammar.Lookup import GF.Grammar.Predef @@ -35,15 +35,10 @@ import GF.Infra.Option import Control.Monad import Data.List import qualified Data.Set as Set - +import Text.PrettyPrint import Debug.Trace --- conditional trace - -prtIf :: (Print a) => Bool -> a -> a -prtIf b t = if b then trace (" " ++ prt t) t else t - -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. type EEnv = () --- not used @@ -81,7 +76,7 @@ evalModule oopts (ms,eenv) mo@(name,m0) gr = MGrammar $ mo : ms evalOp g@(MGrammar ((_,m) : _)) i = do - info <- lookupTree prt i $ jments m + info <- lookupTree showIdent i $ jments m info' <- evalResInfo oopts gr (i,info) return $ updateRes g name i info' @@ -97,7 +92,7 @@ updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info evalResInfo oopts gr (c,info) = case info of - ResOper pty pde -> eIn "operation" $ do + ResOper pty pde -> eIn (text "operation") $ do pde' <- case pde of Just de | optres -> liftM Just $ comp de _ -> return pde @@ -106,7 +101,7 @@ evalResInfo oopts gr (c,info) = case info of _ -> return info where comp = if optres then computeConcrete gr else computeConcreteRec gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) optim = flag optOptimizations oopts optres = OptExpand `Set.member` optim @@ -115,9 +110,9 @@ evalCncInfo :: Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info evalCncInfo opts gr cnc abs (c,info) = do - seq (prtIf (verbAtLeast opts Verbose) c) $ return () + (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () - errIn ("optimizing" +++ prt c) $ case info of + errIn ("optimizing " ++ showIdent c) $ case info of CncCat ptyp pde ppr -> do pde' <- case (ptyp,pde) of @@ -127,12 +122,12 @@ evalCncInfo opts gr cnc abs (c,info) = do liftM Just $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ) _ -> return pde -- indirection - ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ prt c) + ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c) return (CncCat ptyp pde' ppr') CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $ - eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do + eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd (cont,val,[])) $$ text "of function") $ do pde' <- case pde of Just de -> liftM Just $ pEval ty de Nothing -> return pde @@ -142,11 +137,11 @@ evalCncInfo opts gr cnc abs (c,info) = do _ -> return info where pEval = partEval opts gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) -- | the main function for compiling linearizations partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do +partEval opts gr (context, val) trm = errIn (render (text "parteval" <+> ppTerm Qualified 0 trm)) $ do let vars = map fst context args = map Vr vars subst = [(v, Vr v) | v <- vars] @@ -199,7 +194,7 @@ mkLinDefault gr typ = do ts' <- mapM mkDefField ts return $ R $ [assign l t | (l,t) <- zip ls ts'] _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> prtBad "linearization type field cannot be" typ + _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ)) -- | Form the printname: if given, compute. If not, use the computed -- lin for functions, cat name for cats (dispatch made in evalCncDef above). @@ -210,8 +205,8 @@ evalPrintname gr c ppr lin = case ppr of Just pr -> comp pr Nothing -> case lin of - Just t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm - Nothing -> return $ K $ prt c ---- + Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)) + Nothing -> return $ K $ showIdent c ---- where comp = computeConcrete gr diff --git a/src/GF/Compile/OptimizeGF.hs b/src/GF/Compile/OptimizeGF.hs index 8f7a0efef..d68ede00b 100644 --- a/src/GF/Compile/OptimizeGF.hs +++ b/src/GF/Compile/OptimizeGF.hs @@ -23,7 +23,6 @@ import GF.Grammar.Grammar import GF.Grammar.Lookup import GF.Infra.Ident import qualified GF.Grammar.Macros as C -import GF.Grammar.PrGrammar (prt) import qualified GF.Infra.Modules as M import GF.Data.Operations @@ -86,7 +85,7 @@ factor c i t = case t of --- we hope this will be fresh and don't check... in GFC would be safe -qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i)) +qqIdent c i = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i)) -- we need to replace subterms diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 0c9a5c9fe..b7ef65fe9 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -33,7 +33,7 @@ import GF.Grammar.Predef import GF.Infra.Modules import GF.Infra.Ident import GF.Grammar.Macros -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import GF.Grammar.AppPredefined import GF.Grammar.Lookup import GF.Grammar.Printer @@ -55,7 +55,7 @@ renameSourceTerm g m t = do renameTerm status [] t renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] -renameModule ms (name,mo) = errIn ("renaming module" +++ prt name) $ do +renameModule ms (name,mo) = errIn ("renaming module" +++ showIdent name) $ do let js1 = jments mo status <- buildStatus (MGrammar ms) name mo js2 <- mapsErrTree (renameInfo mo status) js1 @@ -69,19 +69,19 @@ type StatusInfo = Ident -> Term renameIdentTerm :: Status -> Term -> Err Term renameIdentTerm env@(act,imps) t = - errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $ + errIn (render (text "atomic term" <+> ppTerm Unqualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs)))) $ case t of Vr c -> ident predefAbs c Cn c -> ident (\_ s -> Bad s) c Q m' c | m' == cPredef {- && isInPredefined c -} -> return t Q m' c -> do m <- lookupErr m' qualifs - f <- lookupTree prt c m + f <- lookupTree showIdent c m return $ f c QC m' c | m' == cPredef {- && isInPredefined c -} -> return t QC m' c -> do m <- lookupErr m' qualifs - f <- lookupTree prt c m + f <- lookupTree showIdent c m return $ f c _ -> return t where @@ -94,14 +94,14 @@ renameIdentTerm env@(act,imps) t = | isPredefCat c = return $ Q cPredefAbs c | otherwise = Bad s - ident alt c = case lookupTree prt c act of + ident alt c = case lookupTree showIdent c act of Ok f -> return $ f c - _ -> case lookupTreeManyAll prt opens c of + _ -> case lookupTreeManyAll showIdent opens c of [f] -> return $ f c - [] -> alt c ("constant not found:" +++ prt c) + [] -> alt c (render (text "constant not found:" <+> ppIdent c)) fs -> case nub [f c | f <- fs] of [tr] -> return tr - ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t) + ts@(t:_) -> trace (render (text "Warning: conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))) (return t) -- a warning will be generated in CheckGrammar, and the head returned -- in next V: -- Bad $ "conflicting imports:" +++ unwords (map prt ts) @@ -152,7 +152,7 @@ forceQualif o = case o of renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info) renameInfo mo status (i,info) = errIn - ("renaming definition of" +++ prt i +++ showPosition mo i) $ + (render (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i)) $ liftM ((,) i) $ case info of AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) (renPerh (mapM rent) pfs) @@ -210,7 +210,7 @@ renameTerm env vars = ren vars where Ok t -> return t _ -> case liftM (flip P l) $ renid t of Ok t -> return t -- const proj last - _ -> prtBad "unknown qualified constant" trm + _ -> Bad (render (text "unknown qualified constant" <+> ppTerm Qualified 0 trm)) EPatt p -> do (p',_) <- renpatt p @@ -233,7 +233,7 @@ renamePattern env patt = case patt of c' <- renid $ Vr c case c' of Q p d -> renp $ PM p d - _ -> prtBad "unresolved pattern" patt + _ -> Bad (render (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)) PC c ps -> do c' <- renid $ Cn c @@ -254,7 +254,7 @@ renamePattern env patt = case patt of PM p c -> do (p', c') <- case renid (Q p c) of Ok (Q p' c') -> return (p',c') - _ -> prtBad "not a pattern macro" patt + _ -> Bad (render (text "not a pattern macro" <+> ppPatt Unqualified 0 patt)) return (PM p' c', []) PV x -> do case renid (Vr x) of diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs index fabe7e2a1..4508c8a17 100644 --- a/src/GF/Compile/TC.hs +++ b/src/GF/Compile/TC.hs @@ -58,7 +58,7 @@ lookupConst :: Theory -> QIdent -> Err Val lookupConst th f = th f lookupVar :: Env -> Ident -> Err Val -lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g) +lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((IW,uVal):g) -- wild card IW: no error produced, ?0 instead. type TCEnv = (Int,Env,Env) @@ -130,7 +130,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do (t',cs) <- checkExp th (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) return (AAbs x a' t', cs) - _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ + _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) Prod x a b -> do testErr (typ == vType) "expected Type" @@ -146,7 +146,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do r <- mapM (checkAssign th tenv ys) xs let (xs,css) = unzip r return (AR xs, concat css) - _ -> prtBad ("record type expected for" +++ prt e +++ "instead of") typ + _ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)]) return (AP r' l typ,cs) @@ -181,8 +181,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of (a',csa) <- checkExp th tenv t (VClos env a) b' <- whnf $ VClos ((x,VClos rho t):env) b return $ (AApp f' a' b', b', csf ++ csa) - _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ - _ -> prtBad "cannot infer type of expression" e + _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) + _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e)) checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) checkLabelling th tenv (lbl,typ) = do @@ -224,7 +224,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ let tenv' = (length binds, sigma ++ rho, binds ++ gamma) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt - _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ + _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ)) [] -> do (e,cs) <- checkExp th tenv t ty return (([],e),cs) @@ -242,7 +242,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ PFloat n -> (EFloat n : ps, i, g, k) PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') where (xss,j,g',k') = foldr p2t ([],i,g,k) xs - _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" + _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch") upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables @@ -280,8 +280,8 @@ checkPatt th tenv exp val = do (a',_,csa) <- checkExpP tenv t (VClos env a) b' <- whnf $ VClos ((x,VClos rho t):env) b return $ (AApp f' a' b', b', csf ++ csa) - _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ - _ -> prtBad "cannot typecheck pattern" exp + _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) + _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) -- auxiliaries diff --git a/src/GF/Compile/TypeCheck.hs b/src/GF/Compile/TypeCheck.hs index 71fe5b067..20c53c234 100644 --- a/src/GF/Compile/TypeCheck.hs +++ b/src/GF/Compile/TypeCheck.hs @@ -21,6 +21,7 @@ module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should n import GF.Data.Operations +import GF.Infra.CheckM import GF.Grammar.Abstract import GF.Grammar.Lookup import GF.Grammar.Unify @@ -29,6 +30,7 @@ import GF.Compile.Refresh import GF.Compile.AbsCompute import GF.Compile.TC +import Text.PrettyPrint import Control.Monad (foldM, liftM, liftM2) -- | invariant way of creating TCEnv from context @@ -65,14 +67,14 @@ grammar2theory gr (m,f) = case lookupFunType gr m f of Ok cont -> return $ cont2val cont _ -> Bad s -checkContext :: Grammar -> Context -> [String] +checkContext :: Grammar -> Context -> [Message] checkContext st = checkTyp st . cont2exp -checkTyp :: Grammar -> Type -> [String] -checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType +checkTyp :: Grammar -> Type -> [Message] +checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType -checkDef :: Grammar -> Fun -> Type -> [Equation] -> [String] -checkDef gr (m,fun) typ eqs = err singleton prConstrs $ do +checkDef :: Grammar -> Fun -> Type -> [Equation] -> [Message] +checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs let (bs,css) = unzip bcs (constrs,_) <- unifyVal (concat css) diff --git a/src/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs index c03783a52..8777c1287 100644 --- a/src/GF/Grammar/Abstract.hs +++ b/src/GF/Grammar/Abstract.hs @@ -19,7 +19,7 @@ module GF.Grammar.Values, module GF.Grammar.Macros, module GF.Infra.Ident, module GF.Grammar.MMacros, -module GF.Grammar.PrGrammar, +module GF.Grammar.Printer, Grammar @@ -30,7 +30,7 @@ import GF.Grammar.Values import GF.Grammar.Macros import GF.Infra.Ident import GF.Grammar.MMacros -import GF.Grammar.PrGrammar +import GF.Grammar.Printer type Grammar = SourceGrammar --- diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs index cfb6baf1d..248445c0c 100644 --- a/src/GF/Grammar/AppPredefined.hs +++ b/src/GF/Grammar/AppPredefined.hs @@ -20,8 +20,9 @@ import GF.Data.Operations import GF.Grammar.Predef import GF.Grammar.Grammar import GF.Grammar.Macros -import GF.Grammar.PrGrammar (prt,prt_,prtBad) +import GF.Grammar.Printer import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint -- predefined function type signatures and definitions. AR 12/3/2003. @@ -56,7 +57,7 @@ typPredefined f ([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[]) | f == cTake = return $ mkFunType [typeInt,typeTok] typeTok | f == cTk = return $ mkFunType [typeInt,typeTok] typeTok - | otherwise = prtBad "unknown in Predef:" f + | otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f)) varL :: Ident varL = identC (BS.pack "L") @@ -89,7 +90,7 @@ appPredefined t = case t of (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse (EInt i, EInt j) | f == cLessInt -> retb $ if i retb $ EInt $ i+j - (_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ prt t + (_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t) (_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags (_, t) | f == cToStr -> trm2str t >>= retb _ -> retb t ---- prtBad "cannot compute predefined" t @@ -137,11 +138,11 @@ trm2str t = case t of T _ ((_,s):_) -> trm2str s TSh _ ((_,s):_) -> trm2str s V _ (s:_) -> trm2str s - C _ _ -> return $ t - K _ -> return $ t - S c _ -> trm2str c - Empty -> return $ t - _ -> prtBad "cannot get Str from term" t + C _ _ -> return $ t + K _ -> return $ t + S c _ -> trm2str c + Empty -> return $ t + _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) -- simultaneous recursion on type and term: type arg is essential! -- But simplify the task by assuming records are type-annotated diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs index 66a978770..3e78a48b6 100644 --- a/src/GF/Grammar/Lockfield.hs +++ b/src/GF/Grammar/Lockfield.hs @@ -21,14 +21,13 @@ import qualified Data.ByteString.Char8 as BS import GF.Infra.Ident import GF.Grammar.Grammar import GF.Grammar.Macros -import GF.Grammar.PrGrammar import GF.Data.Operations lockRecType :: Ident -> Type -> Err Type lockRecType c t@(RecType rs) = let lab = lockLabel c in - return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"] + return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"] then t --- don't add an extra copy of lock field, nor predef cats else RecType (rs ++ [(lockLabel c, RecType [])]) lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])] diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index f6cf60873..c0cbbe962 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -16,20 +16,20 @@ ----------------------------------------------------------------------------- module GF.Grammar.Lookup ( - lookupIdent, - lookupIdentInfo, - lookupIdentInfoIn, - lookupOrigInfo, - lookupResDef, - lookupResDefKind, + lookupIdent, + lookupIdentInfo, + lookupIdentInfoIn, + lookupOrigInfo, + lookupResDef, + lookupResDefKind, lookupResType, - lookupOverload, + lookupOverload, lookupParams, lookupParamValues, lookupFirstTag, - lookupValueIndex, - lookupIndexValue, - allOrigInfos, + lookupValueIndex, + lookupIndexValue, + allOrigInfos, allParamValues, lookupAbsDef, lookupLincat, @@ -39,13 +39,17 @@ module GF.Grammar.Lookup ( ) where import GF.Data.Operations -import GF.Grammar.Abstract +import GF.Infra.Ident import GF.Infra.Modules +import GF.Grammar.Macros +import GF.Grammar.Grammar +import GF.Grammar.Printer import GF.Grammar.Predef import GF.Grammar.Lockfield import Data.List (nub,sortBy) import Control.Monad +import Text.PrettyPrint -- whether lock fields are added in reuse lock c = lockRecType c -- return @@ -92,7 +96,7 @@ lookupResDefKind gr m c AnyInd _ n -> look False n c ResParam _ -> return (QC m c,2) ResValue _ -> return (QC m c,2) - _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m + _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) lookExt m c = checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)]) @@ -112,7 +116,7 @@ lookupResType gr m c = do AnyInd _ n -> lookupResType gr n c ResParam _ -> return $ typePType ResValue (Just (t,_)) -> return $ qualifAnnotPar m t - _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m + _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) where lookFunType e m c = do a <- abstractOfConcrete gr m @@ -124,7 +128,7 @@ lookupResType gr m c = do AbsFun (Just ty) _ _ -> return $ redirectTerm e ty AbsCat _ _ -> return typeType AnyInd _ n -> lookFun e m c n - _ -> prtBad "cannot find type of reused function" c + _ -> Bad (render (text "cannot find type of reused function" <+> ppIdent c)) lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] lookupOverload gr m c = do @@ -138,7 +142,7 @@ lookupOverload gr m c = do concat tss AnyInd _ n -> lookupOverload gr n c - _ -> Bad $ prt c +++ "is not an overloaded operation" + _ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation") -- | returns the original 'Info' and the module where it was found lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info) @@ -157,7 +161,7 @@ lookupParams gr = look True where case info of ResParam (Just psm) -> return psm AnyInd _ n -> look False n c - _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m + _ -> Bad $ render (ppIdent c <+> text "has no parameters defined in resource" <+> ppIdent m) lookExt m c = checks [look False n c | n <- allExtensions gr m] @@ -177,21 +181,21 @@ lookupFirstTag gr m c = do vs <- lookupParamValues gr m c case vs of v:_ -> return v - _ -> prtBad "no parameter values given to type" c + _ -> Bad (render (text "no parameter values given to type" <+> ppIdent c)) lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term lookupValueIndex gr ty tr = do ts <- allParamValues gr ty case lookup tr $ zip ts [0..] of Just i -> return $ Val tr ty i - _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty + _ -> Bad $ render (text "no index for" <+> ppTerm Unqualified 0 tr <+> text "in" <+> ppTerm Unqualified 0 ty) lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term lookupIndexValue gr ty i = do ts <- allParamValues gr ty if i < length ts then return $ ts !! i - else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty + else Bad $ render (text "no value for index" <+> int i <+> text "in" <+> ppTerm Unqualified 0 ty) allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] allOrigInfos gr m = errVal [] $ do @@ -209,7 +213,7 @@ allParamValues cnc ptyp = case ptyp of let (ls,tys) = unzip $ sortByFst r tss <- mapM allPV tys return [R (zipAssign ls ts) | ts <- combinations tss] - _ -> prtBad "cannot find parameter values for" ptyp + _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) where allPV = allParamValues cnc -- to normalize records and record types @@ -228,7 +232,7 @@ qualifAnnotPar m t = case t of _ -> composSafeOp (qualifAnnotPar m) t lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) -lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do +lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of @@ -244,7 +248,7 @@ lookupLincat gr m c = do case info of CncCat (Just t) _ _ -> return t AnyInd _ n -> lookupLincat gr n c - _ -> Bad $ prt c +++ "has no linearization type in" +++ prt m + _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) -- | this is needed at compile time lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type @@ -254,7 +258,7 @@ lookupFunType gr m c = do case info of AbsFun (Just t) _ _ -> return t AnyInd _ n -> lookupFunType gr n c - _ -> prtBad "cannot find type of" c + _ -> Bad (render (text "cannot find type of" <+> ppIdent c)) -- | this is needed at compile time lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context @@ -264,7 +268,7 @@ lookupCatContext gr m c = do case info of AbsCat (Just co) _ -> return co AnyInd _ n -> lookupCatContext gr n c - _ -> prtBad "unknown category" c + _ -> Bad (render (text "unknown category" <+> ppIdent c)) -- The first type argument is uncomputed, usually a category symbol. -- This is a hack to find implicit (= reused) opers. diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs index 84b365225..15e18231e 100644 --- a/src/GF/Grammar/MMacros.hs +++ b/src/GF/Grammar/MMacros.hs @@ -18,7 +18,7 @@ import GF.Data.Operations --import GF.Data.Zipper import GF.Grammar.Grammar -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import GF.Infra.Ident import GF.Compile.Refresh import GF.Grammar.Values @@ -27,6 +27,8 @@ import GF.Grammar.Macros import Control.Monad import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint + {- nodeTree :: Tree -> TrNode argsTree :: Tree -> [Tree] @@ -178,13 +180,13 @@ val2expP :: Bool -> Val -> Err Exp val2expP safe v = case v of VClos g@(_:_) e@(Meta _) -> if safe - then prtBad "unsafe value substitution" v + then Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 v)) else substVal g e VClos g e -> substVal g e VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c) VCn c -> return $ qq c VGen i x -> if safe - then prtBad "unsafe val2exp" v + then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v)) else return $ Vr $ x --- in editing, no alpha conversions presentv VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs return (RecType xs) diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index b195292eb..6749f1bc9 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -24,11 +24,12 @@ import GF.Infra.Ident import GF.Grammar.Grammar import GF.Grammar.Values import GF.Grammar.Predef -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import Control.Monad (liftM, liftM2) import Data.Char (isDigit) import Data.List (sortBy) +import Text.PrettyPrint firstTypeForm :: Type -> Err (Context, Type) firstTypeForm t = case t of @@ -50,7 +51,7 @@ qTypeForm t = case t of QC m c -> return ([],(m,c),[]) _ -> - prtBad "no normal form of type" t + Bad (render (text "no normal form of type" <+> ppTerm Unqualified 0 t)) qq :: QIdent -> Term qq (m,c) = Q m c @@ -94,7 +95,7 @@ getMCat t = case t of QC m c -> return (m,c) Sort c -> return (identW, c) App f _ -> getMCat f - _ -> prtBad "no qualified constant" t + _ -> Bad (render (text "no qualified constant" <+> ppTerm Unqualified 0 t)) typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) typeSkeleton typ = do @@ -231,7 +232,7 @@ mkRecType = mkRecTypeN 0 record2subst :: Term -> Err Substitution record2subst t = case t of R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs] - _ -> prtBad "record expected, found" t + _ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t)) typeType, typePType, typeStr, typeTok, typeStrs :: Term @@ -304,8 +305,8 @@ plusRecType t1 t2 = case (t1, t2) of (RecType r1, RecType r2) -> case filter (`elem` (map fst r1)) (map fst r2) of [] -> return (RecType (r1 ++ r2)) - ls -> Bad $ "clashing labels" +++ unwords (map prt ls) - _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) + ls -> Bad $ render (text "clashing labels" <+> hsep (map ppLabel ls)) + _ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) plusRecord :: Term -> Term -> Err Term plusRecord t1 t2 = @@ -314,7 +315,7 @@ plusRecord t1 t2 = (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV - _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2) + _ -> Bad $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) -- | default linearization type defLinType :: Type @@ -463,7 +464,7 @@ term2patt trm = case termForm trm of Ok ([], Cn c, []) -> do return (PMacro c) - _ -> prtBad "no pattern corresponds to term" trm + _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm) patt2term :: Patt -> Term patt2term pt = case pt of @@ -529,7 +530,7 @@ strsFromTerm t = case t of FV ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat Alias _ _ d -> strsFromTerm d --- should not be needed... - _ -> prtBad "cannot get Str from term" t + _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg stringFromTerm :: Term -> String @@ -708,10 +709,11 @@ isInOneType t = case t of sortRec :: [(Label,a)] -> [(Label,a)] sortRec = sortBy ordLabel where - ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of - ("s",_) -> LT - (_,"s") -> GT - (s1,s2) -> compare s1 s2 + ordLabel (r1,_) (r2,_) = + case (showIdent (label2ident r1), showIdent (label2ident r2)) of + ("s",_) -> LT + (_,"s") -> GT + (s1,s2) -> compare s1 s2 diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs index a14b405f3..0fb23f531 100644 --- a/src/GF/Grammar/PatternMatch.hs +++ b/src/GF/Grammar/PatternMatch.hs @@ -21,20 +21,20 @@ import GF.Data.Operations import GF.Grammar.Grammar import GF.Infra.Ident import GF.Grammar.Macros -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import Data.List import Control.Monad - +import Text.PrettyPrint import Debug.Trace matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) matchPattern pts term = if not (isInConstantForm term) - then prtBad "variables occur in" term + then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) else do term' <- mkK term - errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $ + errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $ findMatch [([p],t) | (p,t) <- pts] [term'] where -- to capture all Str with string pattern matching @@ -48,7 +48,7 @@ matchPattern pts term = K w -> return [w] C v w -> liftM2 (++) (getS v) (getS w) Empty -> return [] - _ -> prtBad "cannot get string from" s + _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) testOvershadow :: [Patt] -> [Term] -> Err [Patt] testOvershadow pts vs = do @@ -59,10 +59,10 @@ testOvershadow pts vs = do findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) findMatch cases terms = case cases of - [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + [] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) (patts,_):_ | length patts /= length terms -> - Bad ("wrong number of args for patterns :" +++ - unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) + Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> + text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) (patts,val):cc -> case mapM tryMatch (zip patts terms) of Ok substs -> return (val, concat substs) _ -> findMatch cc terms @@ -122,7 +122,7 @@ tryMatch (p,t) = do (PNeg p',_) -> case tryMatch (p',t) of Bad _ -> return [] - _ -> prtBad "no match with negative pattern" p + _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p)) (PSeq p1 p2, ([],K s, [])) -> do let cuts = [splitAt n s | n <- [0 .. length s]] @@ -138,7 +138,7 @@ tryMatch (p,t) = do (PChar, ([],K [_], [])) -> return [] (PChars cs, ([],K [c], [])) | elem c cs -> return [] - _ -> prtBad "no match in case expr for" t + _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) isInConstantForm :: Term -> Bool isInConstantForm trm = case trm of diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs index e366f45d5..a5beec99a 100644 --- a/src/GF/Grammar/Printer.hs +++ b/src/GF/Grammar/Printer.hs @@ -16,11 +16,14 @@ module GF.Grammar.Printer , ppTerm , ppTermTabular , ppPatt + , ppValue + , ppConstrs ) where import GF.Infra.Ident import GF.Infra.Modules import GF.Infra.Option +import GF.Grammar.Values import GF.Grammar.Grammar import GF.Data.Operations import Text.PrettyPrint @@ -225,6 +228,22 @@ ppPatt q d (PFloat f) = double f ppPatt q d (PString s) = str s ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) +ppValue :: TermPrintQual -> Int -> Val -> Doc +ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging +ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) +ppValue q d (VCn (_,c)) = ppIdent c +ppValue q d (VClos env e) = case e of + Meta _ -> ppTerm q d e <> ppEnv env + _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging +ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs])) +ppValue q d VType = text "Type" + +ppConstrs :: Constraints -> [Doc] +ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w)) + +ppEnv :: Env -> Doc +ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e) + str s = doubleQuotes (text s) ppDecl q (id,typ) diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs index 68f8b3352..f367dc891 100644 --- a/src/GF/Grammar/Unify.hs +++ b/src/GF/Grammar/Unify.hs @@ -18,9 +18,9 @@ module GF.Grammar.Unify (unifyVal) where import GF.Grammar.Abstract - import GF.Data.Operations +import Text.PrettyPrint import Data.List (partition) unifyVal :: Constraints -> Err (Constraints,MetaSubst) @@ -64,13 +64,13 @@ unify e1 e2 g = unify b c' g (App c a, App d b) -> case unify c d g of Ok g1 -> unify a b g1 - _ -> prtBad "fail unify" e1 + _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) (RecType xs,RecType ys) | xs == ys -> return g - _ -> prtBad "fail unify" e1 + _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) extend :: Unifier -> MetaSymb -> Term -> Err Unifier extend g s t | (t == Meta s) = return g - | occCheck s t = prtBad "occurs check" t + | occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t)) | True = return ((s, t) : g) subst_all :: Unifier -> Term -> Err Term