Reduced clutter in monadic code

+ Eliminated vairous ad-hoc coersion functions between specific monads 
  (IO, Err, IOE, Check) in favor of more general lifting functions
  (liftIO, liftErr).
+ Generalized many basic monadic operations from specific monads to
  arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad),
  thereby completely eliminating the need for lifting functions in lots
  of places.

This can be considered a small step forward towards a cleaner
compiler API and more malleable compiler code in general.

6 files changed, 54 insertions, 54 deletions

diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index fe76d7af8..a48238e42 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -28,14 +28,14 @@ import Data.Char
 import Data.List
 --import System.FilePath
 
-getCF :: FilePath -> String -> Err SourceGrammar
+getCF :: ErrorMonad m => FilePath -> String -> m SourceGrammar
 getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF
 
 ---------------------
 -- the parser -------
 ---------------------
 
-pCF :: String -> Err CF
+pCF :: ErrorMonad m => String -> m CF
 pCF s = do
   rules <- mapM getCFRule $ filter isRule $ lines s
   return $ concat rules
@@ -48,14 +48,14 @@ pCF s = do
 -- fun. C -> item1 item2 ... where unquoted items are treated as cats
 -- Actually would be nice to add profiles to this.
 
-getCFRule :: String -> Err [CFRule]
+getCFRule :: ErrorMonad m => String -> m [CFRule]
 getCFRule s = getcf (wrds s) where
   getcf ws = case ws of
     fun : cat : a : its | isArrow a -> 
-      Ok [L NoLoc (init fun, (cat, map mkIt its))]
+      return [L NoLoc (init fun, (cat, map mkIt its))]
     cat : a : its | isArrow a -> 
-      Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
-    _ -> Bad (" invalid rule:" +++ s)
+      return [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
+    _ -> raise (" invalid rule:" +++ s)
   isArrow a = elem a ["->", "::="] 
   mkIt w = case w of
     ('"':w@(_:_)) -> Right (init w)
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 8db78a0f0..7400ff09b 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -195,17 +195,17 @@ mGrammar ms = MGrammar (Map.fromList ms) ms
 
 -- | we store the module type with the identifier
 
-abstractOfConcrete :: SourceGrammar -> Ident -> Err Ident
+abstractOfConcrete :: ErrorMonad m => SourceGrammar -> Ident -> m Ident
 abstractOfConcrete gr c = do
   n <- lookupModule gr c
   case mtype n of
     MTConcrete a -> return a
-    _ -> Bad $ render (text "expected concrete" <+> ppIdent c)
+    _ -> raise $ render (text "expected concrete" <+> ppIdent c)
 
-lookupModule :: SourceGrammar -> Ident -> Err SourceModInfo
+lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
 lookupModule gr m = case Map.lookup m (moduleMap gr) of
   Just i  -> return i
-  Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
+  Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
 
 isModAbs :: SourceModInfo -> Bool
 isModAbs m =
diff --git a/src/compiler/GF/Grammar/Lockfield.hs b/src/compiler/GF/Grammar/Lockfield.hs
index 5c2f5d0f0..53e58a3ad 100644
--- a/src/compiler/GF/Grammar/Lockfield.hs
+++ b/src/compiler/GF/Grammar/Lockfield.hs
@@ -20,9 +20,9 @@ import GF.Infra.Ident
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
 
-import GF.Data.Operations
+import GF.Data.Operations(ErrorMonad,Err(..))
 
-lockRecType :: Ident -> Type -> Err Type
+lockRecType :: ErrorMonad m => Ident -> Type -> m Type
 lockRecType c t@(RecType rs) = 
   let lab = lockLabel c in
   return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 4076346a8..6bdf87a5c 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -50,19 +50,19 @@ lock c = lockRecType c -- return
 unlock c = unlockRecord c -- return
 
 -- to look up a constant etc in a search tree --- why here? AR 29/5/2008
-lookupIdent :: Ident -> BinTree Ident b -> Err b
+lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b
 lookupIdent c t =
   case lookupTree showIdent c t of
     Ok v  -> return v
-    Bad _ -> Bad ("unknown identifier" +++ showIdent c)
+    Bad _ -> raise ("unknown identifier" +++ showIdent c)
 
-lookupIdentInfo :: SourceModInfo -> Ident -> Err Info
+lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
 lookupIdentInfo mo i = lookupIdent i (jments mo)
 
-lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info
+lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info
 lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
 
-lookupResDef :: SourceGrammar -> QIdent -> Err Term
+lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term
 lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
 
 lookupResDefLoc gr (m,c)
@@ -83,9 +83,9 @@ lookupResDefLoc gr (m,c)
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (noLoc (QC (m,c)))
         ResValue _        -> return (noLoc (QC (m,c)))
-        _   -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
+        _   -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
 
-lookupResType :: SourceGrammar -> QIdent -> Err Type
+lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
 lookupResType gr (m,c) = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
@@ -99,9 +99,9 @@ lookupResType gr (m,c) = do
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _      -> return typePType
     ResValue (L _ t)  -> return t
-    _   -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
+    _   -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
 
-lookupOverload :: SourceGrammar -> QIdent -> Err [([Type],(Type,Term))]
+lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
 lookupOverload gr (m,c) = do
     info <- lookupQIdentInfo gr (m,c)
     case info of
@@ -112,10 +112,10 @@ lookupOverload gr (m,c) = do
                      concat tss
 
       AnyInd _ n  -> lookupOverload gr (n,c)
-      _   -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")
+      _   -> raise $ render (ppIdent c <+> text "is not an overloaded operation")
 
 -- | returns the original 'Info' and the module where it was found
-lookupOrigInfo :: SourceGrammar -> QIdent -> Err (Ident,Info)
+lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
 lookupOrigInfo gr (m,c) = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
@@ -127,14 +127,14 @@ allOrigInfos gr m = errVal [] $ do
   mo <- lookupModule gr m
   return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
 
-lookupParamValues :: SourceGrammar -> QIdent -> Err [Term]
+lookupParamValues :: ErrorMonad m => SourceGrammar -> QIdent -> m [Term]
 lookupParamValues gr c = do
   (_,info) <- lookupOrigInfo gr c
   case info of
     ResParam _ (Just pvs) -> return pvs
-    _                     -> Bad $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
+    _                     -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
 
-allParamValues :: SourceGrammar -> Type -> Err [Term]
+allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
 allParamValues cnc ptyp =
   case ptyp of
     _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -148,12 +148,12 @@ allParamValues cnc ptyp =
        pvs <- allParamValues cnc pt
        vvs <- allParamValues cnc vt
        return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
-    _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
+    _ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
   where
     -- to normalize records and record types
     sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
 
-lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
+lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
 lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
   info <- lookupQIdentInfo gr (m,c)
   case info of
@@ -161,32 +161,32 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
     AnyInd _ n     -> lookupAbsDef gr n c
     _              -> return (Nothing,Nothing)
 
-lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
+lookupLincat :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
 lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
 lookupLincat gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
     CncCat (Just (L _ t)) _ _ _ _ -> return t
     AnyInd _ n                    -> lookupLincat gr n c
-    _                             -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    _                             -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
 
 -- | this is needed at compile time
-lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
+lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
 lookupFunType gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
     AbsFun (Just (L _ t)) _ _ _ -> return t
     AnyInd _ n                  -> lookupFunType gr n c
-    _                           -> Bad (render (text "cannot find type of" <+> ppIdent c))
+    _                           -> raise (render (text "cannot find type of" <+> ppIdent c))
 
 -- | this is needed at compile time
-lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
+lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
 lookupCatContext gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
     AbsCat (Just (L _ co)) -> return co
     AnyInd _ n             -> lookupCatContext gr n c
-    _                      -> Bad (render (text "unknown category" <+> ppIdent c))
+    _                      -> raise (render (text "unknown category" <+> ppIdent c))
 
 
 -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index db17b4451..6798b22d0 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -262,22 +262,22 @@ mkWildCases = mkCases identW
 mkFunType :: [Type] -> Type -> Type
 mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
 
-plusRecType :: Type -> Type -> Err Type
+--plusRecType :: Type -> Type -> Err Type
 plusRecType t1 t2 = case (t1, t2) of
   (RecType r1, RecType r2) -> case
     filter (`elem` (map fst r1)) (map fst r2) of
       [] -> return (RecType (r1 ++ r2))
-      ls -> fail $ render (text "clashing labels" <+> hsep (map ppLabel ls))
-  _ -> fail $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) 
+      ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
+  _ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) 
 
-plusRecord :: Term -> Term -> Err Term
+--plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
  case (t1,t2) of
    (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
                               (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
    (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
    (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
-   _ -> fail $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
+   _ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
 
 -- | default linearization type
 defLinType :: Type
@@ -444,7 +444,7 @@ strsFromTerm t = case t of
            ]
   FV ts -> mapM strsFromTerm ts >>= return . concat
   Strs ts -> mapM strsFromTerm ts >>= return . concat  
-  _ -> fail (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
+  _ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
 
 -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
 stringFromTerm :: Term -> String
@@ -599,20 +599,20 @@ allDependencies ism b =
       AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
       _              -> []
 
-topoSortJments :: SourceModule -> Err [(Ident,Info)]
+topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
 topoSortJments (m,mi) = do
   is <- either
           return
-          (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
+          (\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
           (topoTest (allDependencies (==m) (jments mi)))
   return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
 
-topoSortJments2 :: SourceModule -> Err [[(Ident,Info)]]
+topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
 topoSortJments2 (m,mi) = do
   iss <- either
            return
-           (\cyc -> fail (render (text "circular definitions:"
-                                  <+> fsep (map ppIdent (head cyc)))))
+           (\cyc -> raise (render (text "circular definitions:"
+                                   <+> fsep (map ppIdent (head cyc)))))
            (topoTest2 (allDependencies (==m) (jments mi)))
   return
     [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs
index 071deb709..81541b2a3 100644
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -29,10 +29,10 @@ import Control.Monad
 import Text.PrettyPrint
 --import Debug.Trace
 
-matchPattern :: [(Patt,rhs)] -> Term -> Err (rhs, Substitution)
+matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
 matchPattern pts term = 
   if not (isInConstantForm term)
-    then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
+    then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
   else do
     term' <- mkK term
     errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
@@ -49,20 +49,20 @@ matchPattern pts term =
     K w -> return [w]
     C v w -> liftM2 (++) (getS v) (getS w)
     Empty -> return []
-    _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
+    _ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
 
-testOvershadow :: [Patt] -> [Term] -> Err [Patt]
+testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
 testOvershadow pts vs = do
   let numpts = zip pts [0..]
   let cases  = [(p,EInt i) | (p,i) <- numpts]
   ts <- mapM (liftM fst . matchPattern cases) vs
   return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
 
-findMatch :: [([Patt],rhs)] -> [Term] -> Err (rhs, Substitution)
+findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
 findMatch cases terms = case cases of
-   [] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
+   [] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
    (patts,_):_ | length patts /= length terms -> 
-       Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> 
+       raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> 
                     text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
    (patts,val):cc -> case mapM tryMatch (zip patts terms) of
        Ok substs -> return (val, concat substs)
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
 
       (PNeg p',_) -> case tryMatch (p',t) of
         Bad _ -> return []
-        _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
+        _ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
 
       (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
       (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
       (PChar,  ([],K [_], [])) -> return []
       (PChars cs, ([],K [c], [])) | elem c cs -> return []
 
-      _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
+      _ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
 
 matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
 --matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s