diff options
| -rw-r--r-- | src-3.0/GF/Compile/CheckGrammar.hs | 17 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/Rename.hs | 2 | ||||
| -rw-r--r-- | src-3.0/GF/Data/Operations.hs | 20 |
3 files changed, 31 insertions, 8 deletions
diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs index e47496e97..f8383ea9f 100644 --- a/src-3.0/GF/Compile/CheckGrammar.hs +++ b/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 diff --git a/src-3.0/GF/Compile/Rename.hs b/src-3.0/GF/Compile/Rename.hs index 68f4d754f..312dcb2dd 100644 --- a/src-3.0/GF/Compile/Rename.hs +++ b/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 diff --git a/src-3.0/GF/Data/Operations.hs b/src-3.0/GF/Data/Operations.hs index 1b2033d69..253723876 100644 --- a/src-3.0/GF/Data/Operations.hs +++ b/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 |