CheckGrammar is now using the printer in GF.Grammar.Printer. Fixed bug that was hiding the warnings

src/GF/Infra/CheckM.hs

@@ -12,33 +12,51 @@
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
-module GF.Infra.CheckM (Check,
+module GF.Infra.CheckM
+          (Check, Message, runCheck,
 	       checkError, checkCond, checkWarn, checkUpdate, checkInContext,
 	       checkUpdates, checkReset, checkResets, checkGetContext, 
-	       checkLookup, checkStart, checkErr, checkVal, checkIn, 
-	       prtFail
+	       checkLookup, checkErr, checkIn, checkMap
 	      ) where
 
 import GF.Data.Operations
-import GF.Grammar.Grammar
 import GF.Infra.Ident
-import GF.Grammar.PrGrammar
+import GF.Grammar.Grammar
+import GF.Grammar.Printer
 
--- | the strings are non-fatal warnings
-type Check a = STM (Context,[String]) a
+import qualified Data.Map as Map
+import Text.PrettyPrint
 
-checkError :: String -> Check a
-checkError = raise
+type Message = Doc
+data CheckResult a
+  = Fail              [Message]
+  | Success a Context [Message]
+newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a}
 
-checkCond :: String -> Bool -> Check ()
+instance Monad Check where
+  return x = Check (\ctxt msgs -> Success x ctxt msgs)
+  f >>= g  = Check (\ctxt msgs -> case unCheck f ctxt msgs of
+                                    Success x ctxt msgs -> unCheck (g x) ctxt msgs
+                                    Fail msgs           -> Fail msgs)
+
+instance ErrorMonad Check where
+  raise s = checkError (text s)
+  handle f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of
+                                      Success x ctxt msgs -> Success x ctxt msgs
+                                      Fail (msg:msgs)     -> unCheck (h (render msg)) ctxt msgs)
+
+checkError :: Message -> Check a
+checkError msg = Check (\ctxt msgs -> Fail (msg : msgs))
+
+checkCond :: Message -> Bool -> Check ()
 checkCond s b = if b then return () else checkError s
 
 -- | warnings should be reversed in the end
-checkWarn :: String -> Check ()
-checkWarn s = updateSTM (\ (cont,msg) -> (cont, ("Warning: "++s):msg))
+checkWarn :: Message -> Check ()
+checkWarn msg = Check (\ctxt msgs -> Success () ctxt ((text "Warning:" <+> msg) : msgs))
 
 checkUpdate :: Decl -> Check ()
-checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
+checkUpdate d = Check (\ctxt msgs -> Success () (d:ctxt) msgs)
 
 checkInContext :: [Decl] -> Check r -> Check r
 checkInContext g ch = do
@@ -54,36 +72,36 @@ checkReset :: Check ()
 checkReset = checkResets 1
 
 checkResets :: Int -> Check ()
-checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
+checkResets i = Check (\ctxt msgs -> Success () (drop i ctxt) msgs)
 
 checkGetContext :: Check Context
-checkGetContext = do
-  (co,_) <- readSTM
-  return co
+checkGetContext = Check (\ctxt msgs -> Success ctxt ctxt msgs)
 
 checkLookup :: Ident -> Check Type
 checkLookup x = do
   co <- checkGetContext
-  checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
+  case lookup x co of
+    Nothing -> checkError (text "unknown variable" <+> ppIdent x)
+    Just ty -> return ty
 
-checkStart :: Check a -> Err (a,(Context,[String]))
-checkStart c = appSTM c ([],[])
+runCheck :: Check a -> Either [Message] (a,Context,[Message])
+runCheck c =
+  case unCheck c [] [] of
+    Fail msgs           -> Left          msgs
+    Success v ctxt msgs -> Right (v,ctxt,msgs)
+
+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
+                                             return (k,v)) (Map.toList map)
+                    return (Map.fromAscList xs)
 
 checkErr :: Err a -> Check a
-checkErr e = stm (\s -> do
-  v <- e
-  return (v,s)
-  )
+checkErr (Ok x)    = return x
+checkErr (Bad err) = checkError (text err)
 
-checkVal :: a -> Check a
-checkVal v = return v
-
-prtFail :: Print a => String -> a -> Check b
-prtFail s t = checkErr $ prtBad s t
-
-checkIn :: String -> Check a -> Check a
-checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
-  Bad e -> Bad $ msg ++++ e
-  Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
-    new = take (length ws' - length ws) ws'
-    ws2 = [msg ++++ w | w <- new] ++ ws
+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 ctxt' msgs' | null msgs' -> Success v ctxt' msgs
+                          | otherwise  -> Success v ctxt' ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)