diff options
Diffstat (limited to 'src/GF/Compile')
| -rw-r--r-- | src/GF/Compile/AbsCompute.hs | 23 | ||||
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 2 | ||||
| -rw-r--r-- | src/GF/Compile/Compute.hs | 30 | ||||
| -rw-r--r-- | src/GF/Compile/GrammarToGFCC.hs | 50 | ||||
| -rw-r--r-- | src/GF/Compile/ModDeps.hs | 2 | ||||
| -rw-r--r-- | src/GF/Compile/Optimize.hs | 33 | ||||
| -rw-r--r-- | src/GF/Compile/OptimizeGF.hs | 3 | ||||
| -rw-r--r-- | src/GF/Compile/Rename.hs | 26 | ||||
| -rw-r--r-- | src/GF/Compile/TC.hs | 18 | ||||
| -rw-r--r-- | src/GF/Compile/TypeCheck.hs | 12 |
10 files changed, 96 insertions, 103 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) |