From 0a09f3e0b2f25c02589f5e10b4235303cd218d79 Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 25 Jun 2012 14:01:58 +0000 Subject: [PATCH] Check monad: support for accumulated errors In addition to warnings, the Check monad in GF.Infra.CheckM can now accumulate errors. There are two new functions checkAccumError: Message -> Check () accumulateError :: (a -> Check a) -> a -> Check a The former (with the same type as checkWarn) is used to report an accumulated (nonfatal) error. The latter converts fatal errors into accumulated errors. Accumulated errors are reported as regular errors by runCheck. Also, the Check monad type has been made abstract. --- .../GF/Compile/TypeCheck/ConcreteNew.hs | 8 +- src/compiler/GF/Infra/CheckM.hs | 80 +++++++++++++------ 2 files changed, 58 insertions(+), 30 deletions(-) diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 4ece28cda..26308d945 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -458,7 +458,7 @@ data MetaValue type MetaStore = IntMap.IntMap MetaValue data TcResult a = TcOk a MetaStore [Message] - | TcFail [Message] + | TcFail [Message] -- First msg is error, the rest are warnings? newtype TcM a = TcM {unTcM :: MetaStore -> [Message] -> TcResult a} instance Monad TcM where @@ -480,9 +480,9 @@ tcWarn :: Message -> TcM () tcWarn msg = TcM (\ms msgs -> TcOk () ms ((text "Warning:" <+> msg) : msgs)) runTcM :: TcM a -> Check a -runTcM f = Check (\ctxt msgs -> case unTcM f IntMap.empty msgs of - TcOk x _ msgs -> Success x msgs - TcFail msgs -> Fail msgs) +runTcM f = case unTcM f IntMap.empty [] of + TcOk x _ msgs -> do checkWarnings msgs; return x + TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg newMeta :: Sigma -> TcM MetaId newMeta ty = TcM (\ms msgs -> diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index 5158382b9..d845dd4d4 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -13,52 +13,75 @@ ----------------------------------------------------------------------------- module GF.Infra.CheckM - (Check(..), CheckResult(..), Message, runCheck, - checkError, checkCond, checkWarn, - checkErr, checkIn, checkMap, checkMapRecover - ) where + (Check, CheckResult, Message, runCheck, + checkError, checkCond, checkWarn, checkWarnings, checkAccumError, + checkErr, checkIn, checkMap, checkMapRecover, + accumulateError + ) where import GF.Data.Operations import GF.Infra.Ident -import GF.Grammar.Grammar +import GF.Grammar.Grammar(Context) import GF.Grammar.Printer import qualified Data.Map as Map import Text.PrettyPrint type Message = Doc -data CheckResult a - = Fail [Message] - | Success a [Message] -newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a} +type Error = Message +type Warning = Message +--data Severity = Warning | Error +--type NonFatal = ([Severity,Message]) -- preserves order +type NonFatal = ([Error],[Warning]) +type Accumulate acc ans = acc -> (acc,ans) +data CheckResult a = Fail Error | Success a +newtype Check a + = Check {unCheck :: Context -> Accumulate NonFatal (CheckResult a)} instance Monad Check where - return x = Check (\ctxt msgs -> Success x msgs) - f >>= g = Check (\ctxt msgs -> case unCheck f ctxt msgs of - Success x msgs -> unCheck (g x) ctxt msgs - Fail msgs -> Fail msgs) + return x = Check $ \ctxt ws -> (ws,Success x) + f >>= g = Check $ \ctxt ws -> + case unCheck f ctxt ws of + (ws,Success x) -> unCheck (g x) ctxt ws + (ws,Fail msg) -> (ws,Fail msg) instance ErrorMonad Check where raise s = checkError (text s) - handle f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of - Success x msgs -> Success x msgs - Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs) + handle f h = handle' f (h . render) +handle' f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of + (ws,Success x) -> (ws,Success x) + (ws,Fail msg) -> unCheck (h msg) ctxt ws) + +-- | Report a fatal error checkError :: Message -> Check a -checkError msg = Check (\ctxt msgs -> Fail (msg : msgs)) +checkError msg = Check (\ctxt ws -> (ws,Fail msg)) checkCond :: Message -> Bool -> Check () checkCond s b = if b then return () else checkError s -- | warnings should be reversed in the end checkWarn :: Message -> Check () -checkWarn msg = Check (\ctxt msgs -> Success () ((text "Warning:" <+> msg) : msgs)) +checkWarn msg = Check $ \ctxt (es,ws) -> ((es,(text "Warning:" <+> msg) : ws),Success ()) +checkWarnings = mapM_ checkWarn + +-- | Report a nonfatal (accumulated) error +checkAccumError :: Message -> Check () +checkAccumError msg = Check $ \ctxt (es,ws) -> ((msg:es,ws),Success ()) + +-- | Turn a fatal error into a nonfatal (accumulated) error +accumulateError :: (a -> Check a) -> a -> Check a +accumulateError chk a = + handle' (chk a) $ \ msg -> do checkAccumError msg; return a + +-- | Run an error check, report errors and warnings runCheck :: Check a -> Err (a,String) runCheck c = - case unCheck c [] [] of - Fail msgs -> Bad ( render (vcat (reverse msgs))) - Success v msgs -> Ok (v, render (vcat (reverse msgs))) + case unCheck c [] ([],[]) of + (([],ws),Success v) -> Ok (v, render (vcat (reverse ws))) + ((es,ws),Success v) -> Bad ( render (vcat (reverse (es++ws)))) + ((es,ws),Fail msg) -> Bad ( render (vcat (reverse (msg:es++ws)))) checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b) checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v @@ -80,8 +103,13 @@ checkErr (Ok x) = return x checkErr (Bad err) = checkError (text err) checkIn :: Doc -> Check a -> Check a -checkIn msg c = Check $ \ctxt msgs -> - case unCheck c ctxt [] of - Fail msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs) - Success v msgs' | null msgs' -> Success v msgs - | otherwise -> Success v ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs) +checkIn msg c = Check $ \ctxt msgs0 -> + case unCheck c ctxt ([],[]) of + (msgs,Fail msg) -> (augment msgs0 msgs,Fail (augment1 msg)) + (msgs,Success v) -> (augment msgs0 msgs,Success v) + where + augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws) + augment' msgs0 [] = msgs0 + augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0 + + augment1 msg' = msg $$ nest 3 msg'