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.

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
+runTcM f = case unTcM f IntMap.empty [] of
-                                  TcOk x _ msgs -> Success x msgs
+             TcOk x _ msgs -> do checkWarnings msgs; return x
-                                  TcFail msgs   -> Fail msgs)
+             TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg
 
 newMeta :: Sigma -> TcM MetaId
 newMeta ty = TcM (\ms msgs -> 

src/compiler/GF/Infra/CheckM.hs

@@ -13,52 +13,75 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.CheckM
-          (Check(..), CheckResult(..), Message, runCheck,
+          (Check, CheckResult, Message, runCheck,
-	       checkError, checkCond, checkWarn, 
+	   checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
-	       checkErr, checkIn, checkMap, checkMapRecover
+	   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
+type Error   = Message
-  = Fail      [Message]
+type Warning = Message
-  | Success a [Message]
+--data Severity = Warning | Error
-newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a}
+--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)
+  return x = Check $ \ctxt ws -> (ws,Success x)
-  f >>= g  = Check (\ctxt msgs -> case unCheck f ctxt msgs of
+  f >>= g  = Check $ \ctxt ws ->
-                                    Success x msgs -> unCheck (g x) ctxt msgs
+               case unCheck f ctxt ws of
-                                    Fail msgs      -> Fail msgs)
+                 (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
+  handle f h = handle' f (h . render)
-                                      Success x msgs  -> Success x msgs
-                                      Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs)
 
+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
+  case unCheck c [] ([],[]) of
-    Fail msgs      -> Bad (   render (vcat (reverse msgs)))
+    (([],ws),Success v) -> Ok  (v, render (vcat (reverse ws)))
-    Success v msgs -> Ok  (v, render (vcat (reverse msgs)))
+    ((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 ->
+checkIn msg c = Check $ \ctxt msgs0 ->
-  case unCheck c ctxt [] of
+    case unCheck c ctxt ([],[]) of
-    Fail      msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
+      (msgs,Fail msg)  -> (augment msgs0 msgs,Fail (augment1 msg))
-    Success v msgs' | null msgs' -> Success v msgs
+      (msgs,Success v) -> (augment msgs0 msgs,Success v)
-                    | otherwise  -> Success v ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
+  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'