From 5b577baf02508429951916318f0ebf468d6d3fa4 Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 26 Jun 2012 14:46:18 +0000 Subject: [PATCH] Report many type errors instead of stopping after the first one In GF.Compile.CheckGrammar, use a new topological sorting function that groups independent judgements, allowing them all to be checked before continuing or reporting errors. --- src/compiler/GF/Compile/CheckGrammar.hs | 8 +++++--- src/compiler/GF/Data/Operations.hs | 18 ++++++++++++++++-- src/compiler/GF/Data/Relation.hs | 2 +- src/compiler/GF/Grammar/Macros.hs | 12 +++++++++++- src/compiler/GF/Infra/CheckM.hs | 16 ++++++++++++++-- 5 files changed, 47 insertions(+), 9 deletions(-) diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index d66fdad71..f7af80327 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -53,11 +53,13 @@ checkModule opts mos mo@(m,mi) = do abs <- checkErr $ lookupModule gr a checkCompleteGrammar gr (a,abs) mo _ -> return mo - infos <- checkErr $ topoSortJments mo - foldM updateCheckInfo mo infos + infoss <- checkErr $ topoSortJments2 mo + foldM updateCheckInfos mo infoss where + updateCheckInfos mo0 = commitCheck . foldM updateCheckInfo mo0 + updateCheckInfo mo@(m,mi) (i,info) = do - info <- checkInfo opts mos mo i info + info <- accumulateError (checkInfo opts mos mo i) info return (m,mi{jments=updateTree (i,info) (jments mi)}) -- check if restricted inheritance modules are still coherent diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 7b2afc9fe..781f0a133 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -43,7 +43,7 @@ module GF.Data.Operations (-- * misc functions combinations, -- * topological sorting with test of cyclicity - topoTest, + topoTest, topoTest2, -- * the generic fix point iterator iterFix, @@ -60,7 +60,7 @@ module GF.Data.Operations (-- * misc functions ) where import Data.Char (isSpace, toUpper, isSpace, isDigit) -import Data.List (nub, sortBy, sort, deleteBy, nubBy) +import Data.List (nub, sortBy, sort, deleteBy, nubBy, partition, (\\)) import qualified Data.Map as Map import Data.Map (Map) import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) @@ -267,6 +267,20 @@ combinations t = case t of topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]] topoTest = topologicalSort . mkRel' +-- | topological sorting with test of cyclicity, new version /TH 2012-06-26 +topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]] +topoTest2 g = maybe (Right cycles) Left (tsort g) + where + cycles = findCycles (mkRel' g) + + tsort nes = + case partition (null.snd) nes of + ([],[]) -> Just [] + ([],_) -> Nothing + (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest] + where leaves = map fst ns + + -- | the generic fix point iterator iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] iterFix more start = iter start start diff --git a/src/compiler/GF/Data/Relation.hs b/src/compiler/GF/Data/Relation.hs index 7024a482c..b888a0fd7 100644 --- a/src/compiler/GF/Data/Relation.hs +++ b/src/compiler/GF/Data/Relation.hs @@ -23,7 +23,7 @@ module GF.Data.Relation (Rel, mkRel, mkRel' , isTransitive, isReflexive, isSymmetric , isEquivalence , isSubRelationOf - , topologicalSort) where + , topologicalSort, findCycles) where import Data.Foldable (toList) import Data.List diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index e8842375d..bf7e7047b 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -568,10 +568,20 @@ allDependencies ism b = topoSortJments :: SourceModule -> Err [(Ident,Info)] topoSortJments (m,mi) = do is <- either - return + return (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) (topoTest (allDependencies (==m) (jments mi))) return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) + +topoSortJments2 :: SourceModule -> Err [[(Ident,Info)]] +topoSortJments2 (m,mi) = do + iss <- either + return + (\cyc -> fail (render (text "circular definitions:" + <+> fsep (map ppIdent (head cyc))))) + (topoTest2 (allDependencies (==m) (jments mi))) + return + [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss] {- -- | Smart constructor for PSeq pSeq p1 p2 = diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index ea07d06c4..940701a1d 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -16,7 +16,7 @@ module GF.Infra.CheckM (Check, CheckResult, Message, runCheck, checkError, checkCond, checkWarn, checkWarnings, checkAccumError, checkErr, checkIn, checkMap, checkMapRecover, - accumulateError + accumulateError, commitCheck ) where import GF.Data.Operations @@ -75,6 +75,18 @@ accumulateError :: (a -> Check a) -> a -> Check a accumulateError chk a = handle' (chk a) $ \ msg -> do checkAccumError msg; return a +-- | Turn accumulated errors into a fatal error +commitCheck :: Check a -> Check a +commitCheck c = + Check $ \ ctxt msgs0@(es0,ws0) -> + case unCheck c ctxt ([],[]) of + (([],ws),Success v) -> ((es0,ws++ws0),Success v) + (msgs ,Success _) -> bad msgs0 msgs + ((es,ws),Fail e) -> bad msgs0 ((e:es),ws) + where + bad (es0,ws0) (es,ws) = ((es0,ws++ws0),Fail (list es)) + list = vcat . reverse + -- | Run an error check, report errors and warnings runCheck :: Check a -> Err (a,String) runCheck c = @@ -92,7 +104,7 @@ checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v return (Map.fromAscList xs) checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b) -checkMapRecover f mp = checkMap f' mp +checkMapRecover f mp = commitCheck (checkMap f' mp) where f' key info = accumulateError (f key) info {- checkMapRecover f mp = do