refactor GF.Infra.CheckM and use the CheckM monad in the renamer as well

1 files changed, 16 insertions, 46 deletions

diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs
index a556e5c3a..8a1b42cdf 100644
--- a/src/GF/Infra/CheckM.hs
+++ b/src/GF/Infra/CheckM.hs
@@ -14,9 +14,8 @@
 
 module GF.Infra.CheckM
           (Check, Message, runCheck,
-	       checkError, checkCond, checkWarn, checkUpdate, checkInContext,
-	       checkUpdates, checkReset, checkResets, checkGetContext, 
-	       checkLookup, checkErr, checkIn, checkMap
+	       checkError, checkCond, checkWarn, 
+	       checkErr, checkIn, checkMap
 	      ) where
 
 import GF.Data.Operations
@@ -29,21 +28,21 @@ import Text.PrettyPrint
 
 type Message = Doc
 data CheckResult a
-  = Fail              [Message]
-  | Success a Context [Message]
+  = Fail      [Message]
+  | Success a [Message]
 newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a}
 
 instance Monad Check where
-  return x = Check (\ctxt msgs -> Success x ctxt msgs)
+  return x = Check (\ctxt msgs -> Success x 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)
+                                    Success x 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)
+                                      Success x msgs  -> Success x msgs
+                                      Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs)
 
 checkError :: Message -> Check a
 checkError msg = Check (\ctxt msgs -> Fail (msg : msgs))
@@ -53,42 +52,13 @@ 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 () ctxt ((text "Warning:" <+> msg) : msgs))
+checkWarn msg = Check (\ctxt msgs -> Success () ((text "Warning:" <+> msg) : msgs))
 
-checkUpdate :: Hypo -> Check ()
-checkUpdate d = Check (\ctxt msgs -> Success () (d:ctxt) msgs)
-
-checkInContext :: [Hypo] -> Check r -> Check r
-checkInContext g ch = do
-  i <- checkUpdates g
-  r <- ch
-  checkResets i
-  return r
-
-checkUpdates :: [Hypo] -> Check Int
-checkUpdates ds = mapM checkUpdate ds >> return (length ds)
-
-checkReset :: Check ()
-checkReset = checkResets 1
-
-checkResets :: Int -> Check ()
-checkResets i = Check (\ctxt msgs -> Success () (drop i ctxt) msgs)
-
-checkGetContext :: Check Context
-checkGetContext = Check (\ctxt msgs -> Success ctxt ctxt msgs)
-
-checkLookup :: Ident -> Check Type
-checkLookup x = do
-  co <- checkGetContext
-  case [ty | (b,y,ty) <- co, x == y] of
-    []     -> checkError (text "unknown variable" <+> ppIdent x)
-    (ty:_) -> return ty
-
-runCheck :: Check a -> Either [Message] (a,Context,[Message])
+runCheck :: Check a -> Err (a,String)
 runCheck c =
   case unCheck c [] [] of
-    Fail msgs           -> Left          msgs
-    Success v ctxt msgs -> Right (v,ctxt,msgs)
+    Fail msgs      -> Bad (   render (vcat (reverse msgs)))
+    Success v msgs -> Ok  (v, render (vcat (reverse 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
@@ -102,6 +72,6 @@ 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 ctxt' msgs' | null msgs' -> Success v ctxt' msgs
-                          | otherwise  -> Success v ctxt' ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
+    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)