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.

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