diff options
Diffstat (limited to 'src/compiler/GF')
| -rw-r--r-- | src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs | 8 | ||||
| -rw-r--r-- | 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' |