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

1 files changed, 51 insertions, 59 deletions

diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index 7d61e8a7d..aea39e632 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -22,7 +22,7 @@
 -- Hence we can proceed by @fold@ing "from left to right".
 -----------------------------------------------------------------------------
 
-module GF.Compile.Rename (renameGrammar,
+module GF.Compile.Rename (
 	       renameSourceTerm,
 	       renameModule
 	      ) where
@@ -32,6 +32,7 @@ import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Infra.Modules
 import GF.Infra.Ident
+import GF.Infra.CheckM
 import GF.Grammar.Macros
 import GF.Grammar.Printer
 import GF.Grammar.AppPredefined
@@ -41,25 +42,21 @@ import GF.Data.Operations
 
 import Control.Monad
 import Data.List (nub)
-import Debug.Trace (trace)
 import Text.PrettyPrint
 
-renameGrammar :: SourceGrammar -> Err SourceGrammar
-renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
-
 -- | this gives top-level access to renaming term input in the cc command
-renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
 renameSourceTerm g m t = do
-  mo     <- lookupModule g m
+  mo     <- checkErr $ lookupModule g m
   status <- buildStatus g m mo
   renameTerm status [] t
 
-renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
-renameModule ms (name,mo) = errIn ("renaming module" +++ showIdent name) $ do
+renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
+renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
   let js1 = jments mo
   status <- buildStatus (MGrammar ms) name mo
-  js2    <- mapsErrTree (renameInfo mo status) js1
-  return $ (name, mo {opens = map forceQualif (opens mo), jments = js2}) : ms
+  js2    <- checkMap (renameInfo mo status) js1
+  return (name, mo {opens = map forceQualif (opens mo), jments = js2})
 
 type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
 
@@ -67,20 +64,20 @@ type StatusTree = BinTree Ident StatusInfo
 
 type StatusInfo = Ident -> Term
 
-renameIdentTerm :: Status -> Term -> Err Term
+renameIdentTerm :: Status -> Term -> Check Term
 renameIdentTerm env@(act,imps) t = 
- errIn (render (text "atomic term" <+> ppTerm Unqualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs)))) $
+ checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $
    case t of
   Vr c -> ident predefAbs c
-  Cn c -> ident (\_ s -> Bad s) c
+  Cn c -> ident (\_ s -> checkError s) c
   Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
   Q m' c -> do
-    m <- lookupErr m' qualifs
+    m <- checkErr (lookupErr m' qualifs)
     f <- lookupTree showIdent c m
     return $ f c
   QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
   QC m' c -> do
-    m <- lookupErr m' qualifs
+    m <- checkErr (lookupErr m' qualifs)
     f <- lookupTree showIdent c m
     return $ f c
   _ -> return t
@@ -92,28 +89,21 @@ renameIdentTerm env@(act,imps) t =
    -- this facility is mainly for BWC with GF1: you need not import PredefAbs
    predefAbs c s
      | isPredefCat c = return $ Q cPredefAbs c
-     | otherwise     = Bad s
+     | otherwise     = checkError s
 
    ident alt c = case lookupTree showIdent c act of
       Ok f -> return $ f c
       _ -> case lookupTreeManyAll showIdent opens c of
         [f] -> return $ f c
-        []  -> alt c (render (text "constant not found:" <+> ppIdent c))
+        []  -> alt c (text "constant not found:" <+> ppIdent c)
         fs -> case nub [f c | f <- fs]  of
           [tr] -> return tr
-          ts@(t:_) -> trace (render (text "Warning: conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))) (return t)
+          ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))
+                         return t
             -- a warning will be generated in CheckGrammar, and the head returned
             -- in next V: 
             -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
 
-
---- | would it make sense to optimize this by inlining?
-renameIdentPatt :: Status -> Patt -> Err Patt
-renameIdentPatt env p = do
-  let t = patt2term p
-  t' <- renameIdentTerm env t
-  term2patt t'
-
 info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
 info2status mq (c,i) = case i of
   AbsFun _ _ Nothing -> maybe Con QC mq
@@ -128,11 +118,11 @@ tree2status o = case o of
   OSimple i   -> mapTree (info2status (Just i))
   OQualif i j -> mapTree (info2status (Just j))
 
-buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
+buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
 buildStatus gr c mo = let mo' = self2status c mo in do
     let gr1 = MGrammar ((c,mo) : modules gr)
         ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo
-    mods <- mapM (lookupModule gr1 . openedModule) ops
+    mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
     let sts = map modInfo2status $ zip ops mods    
     return $ if isModCnc mo
       then (emptyBinTree, reverse sts) -- the module itself does not define any names
@@ -148,10 +138,10 @@ forceQualif o = case o of
   OSimple i   -> OQualif i i
   OQualif _ i -> OQualif i i
   
-renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info)
-renameInfo mo status (i,info) = errIn 
-    (render (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i)) $ 
-                                liftM ((,) i) $ case info of
+renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info
+renameInfo mo status i info = checkIn 
+    (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ 
+                                case info of
   AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
                                   (renPerh (mapM rent) pfs)
   AbsFun  pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr)
@@ -175,7 +165,7 @@ renameInfo mo status (i,info) = errIn
 renPerh ren (Just t) = liftM Just $ ren t
 renPerh ren Nothing  = return Nothing
 
-renameTerm :: Status -> [Ident] -> Term -> Err Term
+renameTerm :: Status -> [Ident] -> Term -> Check Term
 renameTerm env vars = ren vars where
   ren vs trm = case trm of
     Abs b x t    -> liftM  (Abs b x) (ren (x:vs) t)
@@ -202,13 +192,13 @@ renameTerm env vars = ren vars where
       b' <- ren (x:vs) b
       return $ Let (x,(m',a')) b'
 
-    P t@(Vr r) l                     -- for constant t we know it is projection
-      | elem r vs -> return trm                           -- var proj first
-      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
-          Ok t -> return t
-          _ -> case liftM (flip P l) $ renid t of
-            Ok t -> return t                              -- const proj last
-            _ -> Bad (render (text "unknown qualified constant" <+> ppTerm Qualified 0 trm))
+    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either 
+                                                               -- record projection from variable or constant $r$ or qualified expression with module $r$
+      | elem r vs -> return trm                                -- try var proj first ..
+      | otherwise -> checks [ renid (Q r (label2ident l))      -- .. and qualified expression second.
+                            , renid t >>= \t -> return (P t l) -- try as a constant at the end
+                            , checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 trm)
+                            ]
 
     EPatt p -> do
       (p',_) <- renpatt p
@@ -224,40 +214,42 @@ renameTerm env vars = ren vars where
   renpatt = renamePattern env
 
 -- | vars not needed in env, since patterns always overshadow old vars
-renamePattern :: Status -> Patt -> Err (Patt,[Ident])
+renamePattern :: Status -> Patt -> Check (Patt,[Ident])
 renamePattern env patt = case patt of
 
   PMacro c -> do
     c' <- renid $ Vr c
     case c' of
       Q p d -> renp $ PM p d
-      _ -> Bad (render (text "unresolved pattern" <+> ppPatt Unqualified 0 patt))
+      _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
 
   PC c ps -> do
     c' <- renid $ Cn c
     case c' of
-      QC m c -> renp $ PP m c ps
-      Q  _ _ -> Bad $ render (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
-      _      -> Bad $ render (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
+      QC m c -> do psvss <- mapM renp ps
+                   let (ps,vs) = unzip psvss
+                   return (PP m c ps, concat vs)
+      Q  _ _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
+      _      -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
 
   PP p c ps -> do
-
-    (p', c') <- case renid (QC p c) of
-      Ok (QC p' c') -> return (p',c')
-      _ -> return (p,c) --- temporarily, for bw compat
+    (QC p' c') <- renid (QC p c)
     psvss <- mapM renp ps
     let (ps',vs) = unzip psvss
     return (PP p' c' ps', concat vs)
 
   PM p c -> do
-    (p', c') <- case renid (Q p c) of
-      Ok (Q p' c') -> return (p',c')
-      _ -> Bad (render (text "not a pattern macro" <+> ppPatt Unqualified 0 patt))
+    x <- renid (Q p c)
+    (p',c') <- case x of
+                 (Q p' c') -> return (p',c')
+                 _         -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
     return (PM p' c', [])
 
-  PV x -> do case renid (Vr x) of
-               Ok (QC m c) -> return (PP m c [],[])
-               _           -> return (patt, [x])
+  PV x -> checks [ renid (Vr x) >>= \t' -> case t' of
+                                             QC m c -> return (PP m c [],[])
+                                             _      -> checkError (text "not a constructor")
+                 , return (patt, [x])
+                 ]
 
   PR r -> do
     let (ls,ps) = unzip r
@@ -293,12 +285,12 @@ renamePattern env patt = case patt of
    renp  = renamePattern env
    renid = renameIdentTerm env
 
-renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
+renameParam :: Status -> (Ident, Context) -> Check (Ident, Context)
 renameParam env (c,co) = do
   co' <- renameContext env co
   return (c,co')
 
-renameContext :: Status -> Context -> Err Context
+renameContext :: Status -> Context -> Check Context
 renameContext b = renc [] where
   renc vs cont = case cont of
     (bt,x,t) : xts 
@@ -315,7 +307,7 @@ renameContext b = renc [] where
   ren = renameTerm b
 
 -- | vars not needed in env, since patterns always overshadow old vars
-renameEquation :: Status -> [Ident] -> Equation -> Err Equation
+renameEquation :: Status -> [Ident] -> Equation -> Check Equation
 renameEquation b vs (ps,t) = do
   (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
   t'        <- renameTerm b (concat vs' ++ vs) t