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

4 files changed, 71 insertions, 47 deletions

diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs
index ab6052a9e..f701b7c3a 100644
--- a/src/GF/Infra/CheckM.hs
+++ b/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
+
+import qualified Data.Map as Map
+import Text.PrettyPrint
 
--- | the strings are non-fatal warnings
-type Check a = STM (Context,[String]) a
+type Message = Doc
+data CheckResult a
+  = Fail              [Message]
+  | Success a Context [Message]
+newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a}
 
-checkError :: String -> Check a
-checkError = raise
+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)
 
-checkCond :: String -> Bool -> Check ()
+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
+
+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)
 
-checkStart :: Check a -> Err (a,(Context,[String]))
-checkStart c = appSTM c ([],[])
+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)
-  )
-
-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
+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 ctxt' msgs' | null msgs' -> Success v ctxt' msgs
+                          | otherwise  -> Success v ctxt' ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
diff --git a/src/GF/Infra/Dependencies.hs b/src/GF/Infra/Dependencies.hs
index 43fe4f458..af2088711 100644
--- a/src/GF/Infra/Dependencies.hs
+++ b/src/GF/Infra/Dependencies.hs
@@ -18,16 +18,16 @@ prDepGraph deps = unlines $ [
   "}"
   ]
  where
-   mkNode (i,dep) = unwords [prIdent i, "[",nodeAttr (modtype dep),"]"]
+   mkNode (i,dep) = unwords [showIdent i, "[",nodeAttr (modtype dep),"]"]
    nodeAttr ty = case ty of
        MTAbstract   -> "style = \"solid\", shape = \"box\""
        MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
        _ -> "style = \"dashed\", shape = \"ellipse\""
    mkArrows (i,dep) = 
-     [unwords [prIdent i,"->",prIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
-     [unwords [prIdent i,"->",prIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
-     [unwords [prIdent i,"->",prIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
-     [unwords [prIdent i,"->",prIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep]
+     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
+     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
+     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
+     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep]
    arrowAttr s = case s of
      "of" -> "style = \"solid\", arrowhead = \"empty\""
      "ex" -> "style = \"solid\""
diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs
index 45ebf3a5b..efe6f9261 100644
--- a/src/GF/Infra/Ident.hs
+++ b/src/GF/Infra/Ident.hs
@@ -13,7 +13,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- * Identifiers
-	      Ident(..), ident2bs, prIdent,
+	      Ident(..), ident2bs, showIdent,
 	      identC, identV, identA, identAV, identW,
 	      argIdent, varStr, varX, isWildIdent, varIndex,
 	      -- * refreshing identifiers
@@ -48,8 +48,8 @@ ident2bs i = case i of
   IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j))
   IW -> BS.pack "_"
 
-prIdent :: Ident -> String
-prIdent i = BS.unpack $! ident2bs i
+showIdent :: Ident -> String
+showIdent i = BS.unpack $! ident2bs i
 
 identC :: BS.ByteString -> Ident
 identV :: BS.ByteString -> Int -> Ident
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index 573c59ca5..0b951dd14 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -33,7 +33,7 @@ module GF.Infra.Modules (
 		IdentM(..),
 		abstractOfConcrete, abstractModOfConcrete,
 		lookupModule, lookupModuleType, lookupInfo,
-                lookupPosition, showPosition,
+                lookupPosition, showPosition, ppPosition,
 		isModAbs, isModRes, isModCnc, isModTrans,
 		sameMType, isCompilableModule, isCompleteModule,
 		allAbstracts, greatestAbstract, allResources,
@@ -45,7 +45,7 @@ import GF.Infra.Option
 import GF.Data.Operations
 
 import Data.List
-
+import Text.PrettyPrint
 
 -- AR 29/4/2003
 
@@ -274,6 +274,12 @@ showPosition mo i = case lookupPosition mo i of
   Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
   _ -> ""
 
+ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc
+ppPosition mo i = case lookupPosition mo i of
+  Ok (f,(b,e)) | b == e    -> text "in" <+> text f <> text ", line" <+> int b
+               | otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e
+  _ -> empty
+
 isModAbs :: ModInfo i a -> Bool
 isModAbs m = case mtype m of
   MTAbstract -> True