From 48558197a8fede5fd4941146f36ee2e544252190 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Tue, 15 Nov 2011 13:33:44 +0000 Subject: [PATCH] more structured format for errors and warnings from the compiler --- src/compiler/GF.hs | 2 +- src/compiler/GF/Compile.hs | 14 ++- src/compiler/GF/Compile/CheckGrammar.hs | 56 ++++++------ src/compiler/GF/Compile/GetGrammar.hs | 2 +- src/compiler/GF/Compile/Rename.hs | 112 +++++++++++------------- src/compiler/GF/Grammar/Parser.y | 2 +- src/compiler/GF/Infra/UseIO.hs | 3 - src/compiler/GFC.hs | 24 +++-- 8 files changed, 110 insertions(+), 105 deletions(-) diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 43a2a0b7f..ba5082fc8 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -46,4 +46,4 @@ mainOpts opts files = ModeInteractive -> mainGFI opts files ModeRun -> mainRunGFI opts files ModeServer -> mainServerGFI opts files - ModeCompiler -> dieIOE (mainGFC opts files) + ModeCompiler -> mainGFC opts files diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index aac2a0fb7..e4fe85aef 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -82,6 +82,13 @@ intermOut opts d doc | dump opts d = ioeIO (hPutStrLn stderr (render (text "\n\n--#" <+> text (show d) $$ doc))) | otherwise = return () +warnOut opts warnings + | null warnings = return () + | otherwise = ioeIO (hPutStrLn stderr $ + if flag optVerbosity opts == Normal + then ('\n':warnings) + else warnings) + -- | the environment type CompileEnv = (Int,SourceGrammar,ModEnv) @@ -173,8 +180,7 @@ compileOne opts env@(_,srcgr,_) file = do compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do - let puts = putPointE Quiet opts - putpp = putPointE Verbose opts + let putpp = putPointE Verbose opts mo1 <- ioeErr $ rebuildModule gr mo intermOut opts DumpRebuild (ppModule Qualified mo1) @@ -198,11 +204,11 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do let mos = modules gr (mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule mos mo1b) - if null warnings then return () else puts warnings $ return () + warnOut opts warnings intermOut opts DumpRename (ppModule Qualified mo2) (mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule mos mo2) - if null warnings then return () else puts warnings $ return () + warnOut opts warnings intermOut opts DumpTypeCheck (ppModule Qualified mo3) if not (flag optTagsOnly opts) diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 1770e60e8..1fe59a346 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -43,26 +43,26 @@ import Text.PrettyPrint -- | checking is performed in the dependency order of modules checkModule :: [SourceModule] -> SourceModule -> Check SourceModule -checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do - checkRestrictedInheritance ms m - m <- case mtype mo of - MTConcrete a -> do let gr = mGrammar (m:ms) - abs <- checkErr $ lookupModule gr a - checkCompleteGrammar gr (a,abs) m - _ -> return m - infos <- checkErr $ topoSortJments m - foldM updateCheckInfo m infos +checkModule mos mo@(m,mi) = do + checkRestrictedInheritance mos mo + mo <- case mtype mi of + MTConcrete a -> do let gr = mGrammar (mo:mos) + abs <- checkErr $ lookupModule gr a + checkCompleteGrammar gr (a,abs) mo + _ -> return mo + infos <- checkErr $ topoSortJments mo + foldM updateCheckInfo mo infos where - updateCheckInfo (name,mo) (i,info) = do - info <- checkInfo ms (name,mo) i info - return (name,mo{jments=updateTree (i,info) (jments mo)}) + updateCheckInfo mo@(m,mi) (i,info) = do + info <- checkInfo mos mo i info + return (m,mi{jments=updateTree (i,info) (jments mi)}) -- check if restricted inheritance modules are still coherent -- i.e. that the defs of remaining names don't depend on omitted names checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () -checkRestrictedInheritance mos (name,mo) = do +checkRestrictedInheritance mos (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]] + let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]] -- the restr. modules themself, with restr. infos mapM_ checkRem mrs where @@ -79,7 +79,7 @@ checkRestrictedInheritance mos (name,mo) = do allDeps = concatMap (allDependencies (const True) . jments . snd) mos checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule -checkCompleteGrammar gr (am,abs) (cm,cnc) = do +checkCompleteGrammar gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do let jsa = jments abs let jsc = jments cnc @@ -112,25 +112,23 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do Ok (CncFun ty Nothing mn mf) -> case mb_def of Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js - Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c + Bad _ -> do checkWarn (text "no linearization of" <+> ppIdent c) return js _ -> do case mb_def of Ok def -> do (cont,val) <- linTypeOfType gr cm ty let linty = (snd (valCat ty),cont,val) return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js - Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c + Bad _ -> do checkWarn (text "no linearization of" <+> ppIdent c) return js AbsCat (Just _) -> case lookupIdent c js of Ok (AnyInd _ _) -> return js Ok (CncCat (Just _) _ _ _) -> return js - Ok (CncCat _ mt mp mpmcfg) -> do - checkWarn $ - text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" + Ok (CncCat Nothing mt mp mpmcfg) -> do + checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}") return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js _ -> do - checkWarn $ - text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" + checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}") return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js _ -> return js @@ -141,11 +139,11 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do 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 (text "function" <+> ppIdent c <+> text "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 (text "category" <+> ppIdent c <+> text "is not in abstract") return js _ -> return $ updateTree i js @@ -154,7 +152,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do -- A May-value has always been checked in its origin module. checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info checkInfo ms (m,mo) c info = do - checkReservedId c + checkIn (ppLocation (msrc mo) NoLoc <> colon) $ + checkReservedId c case info of AbsCat (Just (L loc cont)) -> mkCheck loc "the category" $ @@ -242,7 +241,8 @@ checkInfo ms (m,mo) c info = do _ -> return info where gr = mGrammar ((m,mo) : ms) - chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c) + chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ + nest 2 (text "Happened in" <+> text cat <+> ppIdent c)) mkPar (f,co) = do vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co @@ -257,7 +257,9 @@ checkInfo ms (m,mo) c info = do mkCheck loc cat ss = case ss of [] -> return info - _ -> checkError (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c $$ nest 3 (vcat ss)) + _ -> checkError (ppLocation (msrc mo) loc <> colon $$ + nest 2 (text "Happened in" <+> text cat <+> ppIdent c $$ + nest 2 (vcat ss))) 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/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs index 914a19aac..65f98d29a 100644 --- a/src/compiler/GF/Compile/GetGrammar.hs +++ b/src/compiler/GF/Compile/GetGrammar.hs @@ -38,7 +38,7 @@ getSourceModule opts file0 = ioe $ case runP pModDef content of Left (Pn l c,msg) -> do file <- writeTemp tmp let location = file++":"++show l++":"++show c - return (Bad (location++": "++msg)) + return (Bad (location++":\n "++msg)) Right (i,mi) -> do removeTemp tmp return (Ok (i,mi{mflags=mflags mi `addOptions` opts, msrc=file0})) `catch` (return . Bad . show) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 1d3db181c..32ba76f9b 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -24,7 +24,6 @@ module GF.Compile.Rename ( renameSourceTerm, - renameSourceJudgement, renameModule ) where @@ -47,20 +46,12 @@ import Text.PrettyPrint renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term renameSourceTerm g m t = do mi <- checkErr $ lookupModule g m - status <- buildStatus g m mi + status <- buildStatus g (m,mi) renameTerm status [] t --- | this gives top-level access to renaming term input in the cj command -renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -renameSourceJudgement g m (i,t) = do - mi <- checkErr $ lookupModule g m - status <- buildStatus g m mi - t2 <- renameInfo status (m,mi) i t - return (i,t2) - renameModule :: [SourceModule] -> SourceModule -> Check SourceModule -renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do - status <- buildStatus (mGrammar ms) m mi +renameModule ms mo@(m,mi) = do + status <- buildStatus (mGrammar ms) mo js <- checkMap (renameInfo status mo) (jments mi) return (m, mi{jments = js}) @@ -71,42 +62,45 @@ type StatusTree = BinTree Ident StatusInfo type StatusInfo = Ident -> Term renameIdentTerm :: Status -> Term -> Check Term -renameIdentTerm env@(act,imps) t = - checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $ - case t of - Vr c -> ident predefAbs c - Cn c -> ident (\_ s -> checkError s) c - Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t - Q (m',c) -> do - m <- checkErr (lookupErr m' qualifs) - f <- lookupTree showIdent c m - return $ f c - QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t - QC (m',c) -> do - m <- checkErr (lookupErr m' qualifs) - f <- lookupTree showIdent c m - return $ f c - _ -> return t - where - opens = [st | (OSimple _,st) <- imps] - qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ - [(m, st) | (OQualif _ m, st) <- imps] ++ - [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible +renameIdentTerm env@(act,imps) t0 = + case t0 of + Vr c -> ident predefAbs c + Cn c -> ident (\_ s -> checkError s) c + Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 + Q (m',c) -> do + m <- checkErr (lookupErr m' qualifs) + f <- lookupTree showIdent c m + return $ f c + QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 + QC (m',c) -> do + m <- checkErr (lookupErr m' qualifs) + f <- lookupTree showIdent c m + return $ f c + _ -> return t0 + where + opens = [st | (OSimple _,st) <- imps] + qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ + [(m, st) | (OQualif _ m, st) <- imps] ++ + [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible - -- this facility is mainly for BWC with GF1: you need not import PredefAbs - predefAbs c s - | isPredefCat c = return $ Q (cPredefAbs,c) - | otherwise = checkError s + -- this facility is mainly for BWC with GF1: you need not import PredefAbs + predefAbs c s + | isPredefCat c = return (Q (cPredefAbs,c)) + | otherwise = checkError s - ident alt c = case lookupTree showIdent c act of - Ok f -> return $ f c - _ -> case lookupTreeManyAll showIdent opens c of - [f] -> return $ f c - [] -> alt c (text "constant not found:" <+> ppIdent c) - fs -> case nub [f c | f <- fs] of - [tr] -> return tr - ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts))) - return t + ident alt c = + case lookupTree showIdent c act of + 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))) + fs -> case nub [f c | f <- fs] of + [tr] -> return tr + 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))) + return t -- a warning will be generated in CheckGrammar, and the head returned -- in next V: -- Bad $ "conflicting imports:" +++ unwords (map prt ts) @@ -125,15 +119,15 @@ tree2status o = case o of OSimple i -> mapTree (info2status (Just i)) OQualif i j -> mapTree (info2status (Just j)) -buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status -buildStatus gr c mo = let mo' = self2status c mo in do - let gr1 = prependModule gr (c,mo) - ops = [OSimple e | e <- allExtends gr1 c] ++ mopens mo - mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops - let sts = map modInfo2status $ zip ops mods - return $ if isModCnc mo - then (emptyBinTree, reverse sts) -- the module itself does not define any names - else (mo',reverse sts) -- so the empty ident is not needed +buildStatus :: SourceGrammar -> SourceModule -> Check Status +buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do + let gr1 = prependModule gr mo + ops = [OSimple e | e <- allExtends gr1 m] ++ mopens mi + mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops + let sts = map modInfo2status $ zip ops mods + return (if isModCnc mi + then (emptyBinTree, reverse sts) -- the module itself does not define any names + else (self2status m mi,reverse sts)) -- so the empty ident is not needed modInfo2status :: (OpenSpec,SourceModInfo) -> (OpenSpec, StatusTree) modInfo2status (o,mo) = (o,tree2status o (jments mo)) @@ -143,7 +137,7 @@ self2status c m = mapTree (info2status (Just c)) (jments m) renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info -renameInfo status (m,mi) i info = +renameInfo status (m,mi) i info = case info of AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper) @@ -171,9 +165,9 @@ renameInfo status (m,mi) i info = x <- ren x return (L loc x) - renPair ren (L locx x, L locy y) = do x <- ren x - y <- ren y - return (L locx x, L locy y) + renPair ren (x, y) = do x <- renLoc ren x + y <- renLoc ren y + return (x, y) renEquation :: Status -> Equation -> Check Equation renEquation b (ps,t) = do diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 530795974..3c9eb4564 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -603,7 +603,7 @@ Posn { happyError :: P a -happyError = fail "parse error" +happyError = fail "syntax error" mkListId,mkConsId,mkBaseId :: Ident -> Ident mkListId = prefixId (BS.pack "List") diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index 1240351f6..309b09e46 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -158,9 +158,6 @@ foldIOE f s xs = case xs of Ok v -> foldIOE f v xx Bad m -> return $ (s, Just m) -dieIOE :: IOE a -> IO a -dieIOE x = appIOE x >>= err die return - die :: String -> IO a die s = do hPutStrLn stderr s exitFailure diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index 075b82f18..3fff0701c 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -24,15 +24,21 @@ import System.IO import Control.Exception -mainGFC :: Options -> [FilePath] -> IOE () -mainGFC opts fs = - case () of - _ | null fs -> fail $ "No input files." - _ | all (extensionIs ".cf") fs -> compileCFFiles opts fs - _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs - _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs - _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs - where extensionIs ext = (== ext) . takeExtension +mainGFC :: Options -> [FilePath] -> IO () +mainGFC opts fs = do + r <- appIOE (case () of + _ | null fs -> fail $ "No input files." + _ | all (extensionIs ".cf") fs -> compileCFFiles opts fs + _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs + _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs + _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs) + case r of + Ok x -> return x + Bad msg -> die $ if flag optVerbosity opts == Normal + then ('\n':msg) + else msg + where + extensionIs ext = (== ext) . takeExtension compileSourceFiles :: Options -> [FilePath] -> IOE () compileSourceFiles opts fs =