error recovery in rename and check grammar: report all errors in a module before terminating

src-3.0/GF/Compile/CheckGrammar.hs

@@ -56,6 +56,11 @@ showCheckModule mos m = do
   (st,(_,msg)) <- checkStart $ checkModule mos m
   return (st, unlines $ reverse msg)
 
+mapsCheckTree :: 
+  (Ord a) => ((a,b) -> Check (a,c)) -> BinTree a b -> Check (BinTree a c)
+mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fst)
+
+
 -- | checking is performed in the dependency order of modules
 checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
 checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
@@ -63,24 +68,24 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
   ModMod mo@(Module mt st fs me ops js) -> do
     checkRestrictedInheritance ms (name, mo)
     js' <- case mt of
-      MTAbstract -> mapMTree (checkAbsInfo gr name) js
+      MTAbstract -> mapsCheckTree (checkAbsInfo gr name) js
 
-      MTTransfer a b -> mapMTree (checkAbsInfo gr name) js
+      MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name) js
 
-      MTResource -> mapMTree (checkResInfo gr name) js
+      MTResource -> mapsCheckTree (checkResInfo gr name) js
 
       MTConcrete a -> do
         checkErr $ topoSortOpers $ allOperDependencies name js
         ModMod abs <- checkErr $ lookupModule gr a
         js1 <- checkCompleteGrammar abs mo
-        mapMTree (checkCncInfo gr name (a,abs)) js1
+        mapsCheckTree (checkCncInfo gr name (a,abs)) js1
 
-      MTInterface -> mapMTree (checkResInfo gr name) js
+      MTInterface -> mapsCheckTree (checkResInfo gr name) js
 
       MTInstance a -> do
         ModMod abs <- checkErr $ lookupModule gr a
         -- checkCompleteInstance abs mo -- this is done in Rebuild
-        mapMTree (checkResInfo gr name) js
+        mapsCheckTree (checkResInfo gr name) js
 
     return $ (name, ModMod (Module mt st fs me ops js')) : ms
 

src-3.0/GF/Compile/Rename.hs

@@ -58,7 +58,7 @@ renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod o
   ModMod m@(Module mt st fs me ops js) -> do
     let js1 = jments m
     status <- buildStatus (MGrammar ms) name mod
-    js2    <- mapMTree (renameInfo status) js1
+    js2    <- mapsErrTree (renameInfo status) js1
     let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
     return $ (name,mod2) : ms
 

src-3.0/GF/Data/Operations.hs

@@ -22,7 +22,7 @@ module GF.Data.Operations (-- * misc functions
 		   performOps, repeatUntilErr, repeatUntil, okError, isNotError,
 		   showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList,
 		   mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr,
-		   (!?), errList, singleton, 
+		   (!?), errList, singleton, mapsErr, mapsErrTree,
 		   
 		   -- ** checking
 		   checkUnique, titleIfNeeded, errMsg, errAndMsg,
@@ -183,6 +183,7 @@ mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2))
     nss = length ss
     fxs = map f xs
 
+
 -- | like @foldM@, but also return the latest value if fails
 foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String)
 foldErr f s xs = case xs of
@@ -630,6 +631,23 @@ instance ErrorMonad (STM s) where
                                 `handle` (\e -> let STM g' = (g e) in
                                                     g' s))
 
+-- error recovery with multiple reporting AR 30/5/2008
+mapsErr :: (a -> Err b) -> [a] -> Err [b]
+
+mapsErr f = seqs . map f where
+  seqs es = case es of
+    Ok v : ms -> case seqs ms of
+      Ok vs -> return (v : vs)
+      b     -> b
+    Bad s : ms -> case seqs ms of
+      Ok vs  -> Bad s
+      Bad ss -> Bad (s +++++ ss)
+    [] -> return []
+
+mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c)
+mapsErrTree f t =  mapsErr f (tree2list t) >>= return . sorted2tree
+
+
 -- | if the first check fails try another one
 checkAgain :: ErrorMonad m => m a -> m a -> m a
 checkAgain c1 c2 = handle_ c1 c2