remove the Term(Error) constructor. Better propagation of errors.

src/compiler/GF/Command/SourceCommands.hs

@@ -8,9 +8,11 @@ import qualified Data.Map as Map
 
 import GF.Infra.SIO(MonadSIO(..),restricted)
 import GF.Infra.Option(modifyFlags,optTrace) --,noOptions
-import GF.Data.Operations (chunks,err,raise)
+import GF.Infra.Dependencies(depGraph)
-import GF.Text.Pretty(render)
+import GF.Infra.CheckM
+import GF.Text.Pretty(render,pp)
 import GF.Data.Str(sstr)
+import GF.Data.Operations (chunks,err,raise)
 
 import GF.Grammar hiding (Ident,isPrefixOf)
 import GF.Grammar.Analyse
@@ -20,8 +22,6 @@ import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
 import GF.Compile.Compute.Concrete(normalForm)
 import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
-import GF.Infra.Dependencies(depGraph)
-import GF.Infra.CheckM(runCheck)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
@@ -162,12 +162,11 @@ sourceCommands = Map.fromList [
       do sgr <- getGrammar
          liftSIO (exec opts (toStrings ts) sgr)
 
-    compute_concrete opts ws sgr =
+    compute_concrete opts ws sgr = fmap fst $ runCheck $
       case runP pExp (UTF8.fromString s) of
         Left (_,msg) -> return $ pipeMessage msg
-        Right t      -> return $ err pipeMessage
+        Right t      -> do t <- checkComputeTerm opts sgr t
-                                     (fromString . showTerm sgr style q)
+                           return (fromString (showTerm sgr style q t))
-                                 $ checkComputeTerm opts sgr t
       where
         (style,q) = pOpts TermPrintDefault Qualified opts
         s = unwords ws
@@ -200,16 +199,16 @@ sourceCommands = Map.fromList [
                 | otherwise = unwords $ map prTerm ops
           return $ fromString printed
 
-    show_operations os ts sgr =
+    show_operations os ts sgr = fmap fst $ runCheck $
       case greatestResource sgr of
-        Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
+        Nothing -> checkError (pp "no source grammar in scope; did you import with -retain?")
         Just mo -> do
           let greps = map valueString (listFlags "grep" os)
           let isRaw = isOpt "raw" os
           ops <- case ts of
              _:_ -> do
                let Right t = runP pExp (UTF8.fromString (unwords ts))
-               ty <- err error return $ checkComputeTerm os sgr t
+               ty <- checkComputeTerm os sgr t
                return $ allOpersTo sgr ty
              _   -> return $ allOpers sgr
           let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
@@ -254,14 +253,12 @@ sourceCommands = Map.fromList [
          return void
 
 checkComputeTerm os sgr t =
-  do mo <- maybe (raise "no source grammar in scope") return $
+  do mo <- maybe (checkError (pp "no source grammar in scope")) return $
            greatestResource sgr
-     ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
+     t <- renameSourceTerm sgr mo t
-                                inferLType sgr [] t
+     (t,_) <- inferLType sgr [] t                                
      let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-         t1 = normalForm sgr (L NoLoc identW) t
+     fmap evalStr (normalForm sgr (L NoLoc identW) t)
-         t2 = evalStr t1
-     checkPredefError t2
   where
     -- ** Try to compute pre{...} tokens in token sequences
     evalStr t =

src/compiler/GF/Compile/CheckGrammar.hs

@@ -27,7 +27,7 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
+import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
 import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
 import qualified GF.Compile.Compute.Concrete as CN(normalForm)
 
@@ -120,7 +120,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                                     return js
                    _ -> do
                      case mb_def of
-                       Ok def -> do (cont,val) <- linTypeOfType gr cm ty
+                       Ok def -> do (cont,val) <- linTypeOfType gr cm (L loc ty)
                                     let linty = (snd (valCat ty),cont,val)
                                     return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
                        Bad _  -> do noLinOf c
@@ -140,8 +140,8 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
+                             Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
-                                        do (cont,val) <- linTypeOfType gr cm ty
+                                        do (cont,val) <- linTypeOfType gr cm (L loc ty)
                                            let linty = (snd (valCat ty),cont,val)
                                            return $ Map.insert c (CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
@@ -181,14 +181,10 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $
+                Just (L loc typ) -> chIn loc "linearization type of" $ do
-                                     (if False --flag optNewComp opts
+                                      (typ,_) <- checkLType gr [] typ typeType
-                                        then do (typ,_) <- CN.checkLType gr typ typeType
+                                      typ  <- CN.normalForm gr (L loc c) typ
-                                                typ  <- computeLType gr [] typ
+                                      return (Just (L loc typ))
-                                                return (Just (L loc typ))
-                                        else do (typ,_) <- checkLType gr [] typ typeType
-                                                typ  <- computeLType gr [] typ
-                                                return (Just (L loc typ)))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
                 (Just (L _ typ),Just (L loc def)) ->
@@ -228,20 +224,15 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
     ResOper pty pde -> do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
-           ty'     <- chIn loct "operation" $
+           ty'     <- chIn loct "operation" $ do
-                         (if False --flag optNewComp opts
+                         (ty,_) <- checkLType gr [] ty typeType
-                            then CN.checkLType gr ty typeType >>= return . CN.normalForm gr (L loct c) . fst -- !!
+                         CN.normalForm gr (L loct c) ty
-                            else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
            (de',_) <- chIn locd "operation" $
-                         (if False -- flag optNewComp opts
+                         checkLType gr [] de ty'
-                            then CN.checkLType gr de ty'
-                            else checkLType gr [] de ty')
            return (Just (L loct ty'), Just (L locd de'))
          (Nothing         , Just (L locd de)) -> do
            (de',ty') <- chIn locd "operation" $
-                          (if False -- flag optNewComp opts
+                          inferLType gr [] de
-                            then CN.inferLType gr de
-                            else inferLType gr [] de)
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
@@ -306,8 +297,8 @@ checkReservedId x =
 -- auxiliaries
 
 -- | linearization types and defaults
-linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type)
+linTypeOfType :: Grammar -> ModuleName -> L Type -> Check (Context,Type)
-linTypeOfType cnc m typ = do
+linTypeOfType cnc m (L loc typ) = do
   let (cont,cat) = typeSkeleton typ
   val  <- lookLin cat
   args <- mapM mkLinArg (zip [0..] cont)
@@ -325,6 +316,6 @@ linTypeOfType cnc m typ = do
                              plusRecType vars val
      return (Explicit,symb,rec)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
-      lookupLincat cnc m c >>= computeLType cnc []
+      lookupLincat cnc m c >>= CN.normalForm cnc (L loc c)
      ,return defLinType
      ]

src/compiler/GF/Compile/Compute/Concrete.hs

@@ -16,6 +16,7 @@ import GF.Grammar.Printer
 import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
 import GF.Data.Operations(Err(..),err,errIn,maybeErr,mapPairsM)
 import GF.Data.Utilities(mapFst,mapSnd)
+import GF.Infra.CheckM
 import GF.Infra.Option
 import Data.STRef
 import Data.Maybe(fromMaybe)
@@ -30,12 +31,12 @@ import GF.Text.Pretty
 
 -- * Main entry points
 
-normalForm :: Grammar -> L Ident -> Term -> Term
+normalForm :: Grammar -> L Ident -> Term -> Check Term
 normalForm gr loc t =
-  case runEvalM gr (eval [] t [] >>= value2term 0) of
+  fmap mkFV (runEvalM gr (eval [] t [] >>= value2term 0))
-    Left msg  -> error (render (ppL loc msg))
+  where
-    Right [t] -> t
+    mkFV [t] = t
-    Right ts  -> FV ts
+    mkFV ts  = FV ts
 
 
 data ThunkState s
@@ -52,7 +53,7 @@ data Value s
   | VSusp (Thunk s) (Env s) [Thunk s] (Thunk s -> EvalM s (Value s))
   | VGen  {-# UNPACK #-} !Int [Thunk s]
   | VClosure (Env s) Term
-  | VProd BindType Ident (Value s) (Value s)
+  | VProd BindType Ident (Value s) (Env s) Term
   | VRecType [(Label, Value s)]
   | VR [(Label, Thunk s)]
   | VP (Value s) Label [Thunk s]
@@ -85,7 +86,7 @@ eval env (Meta i)       vs  = do tnk <- newMeta i
                                  return (VMeta tnk env vs)
 eval env (ImplArg t)    []  = eval env t []
 eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
-                                 return (VProd b x v1 (VClosure env (Abs b x t2)))
+                                 return (VProd b x v1 env t2)
 eval env (Typed t ty)   vs  = eval env t vs
 eval env (RecType lbls) []  = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls
                                  return (VRecType lbls)
@@ -137,7 +138,6 @@ eval env (EPatt min max p) [] = return (VPatt min max p)
 eval env (EPattType t)  []  = do v <- eval env t []
                                  return (VPattType v)
 eval env (FV ts)        vs  = msum [eval env t vs | t <- ts]
-eval env (Error msg)    vs  = fail msg
 eval env t              vs  = evalError ("Cannot reduce term" <+> pp t)
 
 apply v                             []  = return v
@@ -289,9 +289,11 @@ value2term i (VClosure env (Abs b x t)) = do
   v <- eval ((x,tnk):env) t []
   t <- value2term (i+1) v
   return (Abs b (identS ('v':show i)) t)
-value2term i (VProd b x v1 v2) = do
+value2term i (VProd b x v1 env t2) = do
   t1 <- value2term i v1
-  t2 <- value2term i v2
+  tnk <- newGen i
+  v2 <- eval ((x,tnk):env) t2 []
+  t2 <- value2term (i+1) v2
   return (Prod b x t1 t2)
 value2term i (VRecType lbls) = do
   lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term i v)) lbls
@@ -342,7 +344,7 @@ value2int _        = Nothing
 -- * Evaluation monad
 
 type MetaThunks s = Map.Map MetaId (Thunk s)
-type Cont s r = MetaThunks s -> r -> ST s (Either Doc r)
+type Cont s r = MetaThunks s -> r -> ST s (CheckResult r)
 newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r)
 
 instance Functor (EvalM s) where
@@ -361,33 +363,33 @@ instance Monad (EvalM s) where
 #endif
 
 instance Fail.MonadFail (EvalM s) where
-  fail msg = EvalM (\gr k _ r -> return (Left (pp msg)))
+  fail msg = EvalM (\gr k _ r -> return (Fail (pp msg)))
 
 instance Alternative (EvalM s) where
-  empty = EvalM (\gr k _ r -> return (Right r))
+  empty = EvalM (\gr k _ r -> return (Success r))
   (EvalM f) <|> (EvalM g) = EvalM $ \gr k mt r -> do
      res <- f gr k mt r
      case res of
-       Left msg -> return (Left msg)
+       Fail msg  -> return (Fail msg)
-       Right r  -> g gr k mt r
+       Success r -> g gr k mt r
 
 instance MonadPlus (EvalM s) where
 
-runEvalM :: Grammar -> (forall s . EvalM s a) -> Either Doc [a]
+runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
 runEvalM gr f =
   case runST (case f of
-                EvalM f -> f gr (\x mt xs -> return (Right (x:xs))) Map.empty []) of
+                EvalM f -> f gr (\x mt xs -> return (Success (x:xs))) Map.empty []) of
-    Left msg -> Left msg
+    Fail msg   -> checkError msg
-    Right xs -> Right (reverse xs)
+    Success xs -> return (reverse xs)
 
 evalError :: Doc -> EvalM s a
-evalError msg = EvalM (\gr k _ r -> return (Left msg))
+evalError msg = EvalM (\gr k _ r -> return (Fail msg))
   
 lookupGlobal :: QIdent -> EvalM s Term
 lookupGlobal q = EvalM $ \gr k mt r -> do
   case lookupResDef gr q of
     Ok t    -> k t mt r
-    Bad msg -> return (Left (pp msg))
+    Bad msg -> return (Fail (pp msg))
 
 newThunk env t = EvalM $ \gr k mt r -> do
  tnk <- newSTRef (Unevaluated env t)

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -18,13 +18,13 @@ import Debug.Trace(trace)
 
 -- | Generate Haskell code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
-concretes2haskell opts absname gr =
+concretes2haskell opts absname gr = do
-  [(filename,render80 $ concrete2haskell opts abstr cncmod)
+  Grammar abstr cncs <- grammar2canonical opts absname gr
-     | let Grammar abstr cncs = grammar2canonical opts absname gr,
+  return [(filename,render80 $ concrete2haskell opts abstr cncmod)
-       cncmod<-cncs,
+             | cncmod<-cncs,
-       let ModId name = concName cncmod
+               let ModId name = concName cncmod
-           filename = showRawIdent name ++ ".hs" :: FilePath
+                   filename = showRawIdent name ++ ".hs" :: FilePath
-  ]
+         ]
 
 -- | Generate Haskell code for the given concrete module.
 -- The only options that make a difference are

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -148,10 +148,9 @@ addPMCFG opts gr opath am cm seqs id info = return (seqs, info)
 
 floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
 
-convert opts gr loc term ty@(_,val) pargs =
+convert opts gr loc term ty@(_,val) pargs = error "TODO: convert"
-  case normalForm gr loc (etaExpand ty term) of
+{-  case normalForm gr loc (etaExpand ty term) of
-    Error s -> fail $ render $ ppL loc ("Predef.error: "++s)
+    term    -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])-}
-    term    -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])
   where
     etaExpand (context,val) = mkAbs pars . flip mkApp args
       where pars = [(Explicit,v) | v <- vars]

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -18,6 +18,7 @@ import GF.Grammar.Predef(cPredef,cInts)
 -- import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)
+import GF.Infra.CheckM
 import PGF2(Literal(..))
 import GF.Compile.Compute.Concrete(normalForm)
 import GF.Grammar.Canonical as C
@@ -27,15 +28,16 @@ import qualified Debug.Trace as T
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
-grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar
-grammar2canonical opts absname gr =
+grammar2canonical opts absname gr = do
-   Grammar (abstract2canonical absname gr)
+  abs <- abstract2canonical absname gr
-           (map snd (concretes2canonical opts absname gr))
+  cncs <- concretes2canonical opts absname gr
+  return (Grammar abs (map snd cncs))
 
 -- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Abstract
+abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
 abstract2canonical absname gr =
-    Abstract (modId absname) (convFlags gr absname) cats funs
+  return (Abstract (modId absname) (convFlags gr absname) cats funs)
   where
     cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
 
@@ -48,7 +50,7 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
-        tf -> error $ "abstract2canonical convHypo: " ++ show tf
+        tf -> error ("abstract2canonical convHypo: " ++ show tf)
 
     convType t =
       case typeForm t of
@@ -61,26 +63,24 @@ abstract2canonical absname gr =
 
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
-concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)]
 concretes2canonical opts absname gr =
-  [(cncname,concrete2canonical gr absname cnc cncmod)
+  sequence
-     | cnc<-allConcretes gr absname,
+    [fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
-       let cncname = "canonical" </> render cnc <.> "gf"
+        | cnc<-allConcretes gr absname,
-           Ok cncmod = lookupModule gr cnc
+          let cncname = "canonical" </> render cnc <.> "gf"
-  ]
+              Ok cncmod = lookupModule gr cnc
+        ]
 
 -- | Generate Canonical GF for the given concrete module.
-concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
+concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
-concrete2canonical gr absname cnc modinfo =
+concrete2canonical gr absname cnc modinfo = do
-  Concrete (modId cnc) (modId absname) (convFlags gr cnc)
+  defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
-      (neededParamTypes S.empty (params defs))
+  return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
-      [lincat | (_,Left lincat) <- defs]
+                   (neededParamTypes S.empty (params defs))
-      [lin | (_,Right lin) <- defs]
+                   [lincat | (_,Left lincat) <- defs]
+                   [lin | (_,Right lin) <- defs])
   where
-    defs = concatMap (toCanonical gr absname) .
-           M.toList $
-           jments modinfo
-
     params = S.toList . S.unions . map fst
 
     neededParamTypes have [] = []
@@ -93,29 +93,22 @@ concrete2canonical gr absname cnc modinfo =
 -- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname (name,jment) =
   case jment of
-    CncCat (Just (L loc typ)) _ _ pprn _ ->
+    CncCat (Just (L loc typ)) _ _ pprn _ -> do
-        [(pts,Left (LincatDef (gId name) (convType ntyp)))]
+      ntyp <- normalForm gr (L loc name) typ
-      where
+      let pts = paramTypes gr ntyp
-        pts = paramTypes gr ntyp
+      return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
-        ntyp = nf loc typ
+    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
-    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
+      let params = [(b,x)|(b,x,_)<-ctx]
-        [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
+          args   = map snd params
-      where
+      e0 <- normalForm gr (L loc name) (mkAbs params (mkApp def (map Vr args)))
-        tts = tableTypes gr [e']
+      let e   = cleanupRecordFields lincat (unAbs (length params) e0)
-
+          tts = tableTypes gr [e]
-        e' = cleanupRecordFields lincat $
+      return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
-             unAbs (length params) $
-             nf loc (mkAbs params (mkApp def (map Vr args)))
-        params = [(b,x)|(b,x,_)<-ctx]
-        args = map snd params
-
     AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
                      Ok (m,jment) -> toCanonical gr absname (name,jment)
-                     _ -> []
+                     _ -> return []
-    _ -> []
+    _ -> return []
   where
-    nf loc = normalForm gr (L loc name)
-
     unAbs 0 t = t
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t

src/compiler/GF/Compile/Optimize.hs

@@ -15,15 +15,16 @@
 
 module GF.Compile.Optimize (optimizeModule) where
 
-import GF.Grammar.Grammar
 import GF.Infra.Ident
+import GF.Infra.CheckM
+import GF.Infra.Option
+import GF.Grammar.Grammar
 import GF.Grammar.Printer
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Compile.Compute.Concrete(normalForm)
 import GF.Data.Operations
-import GF.Infra.Option
 
 import Control.Monad
 import qualified Data.Set as Set
@@ -33,7 +34,7 @@ import Debug.Trace
 
 -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
 
-optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
+optimizeModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule
 optimizeModule opts sgr m@(name,mi)
   | mstatus mi == MSComplete = do
       ids <- topoSortJments m
@@ -47,7 +48,7 @@ optimizeModule opts sgr m@(name,mi)
      info <- evalInfo oopts sgr (name,mi) i info
      return (mi{jments=Map.insert i info (jments mi)})
 
-evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
+evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
 evalInfo opts sgr m c info = do
 
  (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
@@ -75,7 +76,9 @@ evalInfo opts sgr m c info = do
         return (Just (L loc (factor param c 0 re)))
       _ -> return pre   -- indirection
 
-    let ppr' = fmap (evalPrintname sgr c) ppr
+    ppr' <- case ppr of
+              Just pr -> fmap Just (evalPrintname sgr c pr)
+              Nothing -> return ppr
 
     return (CncCat ptyp pde' pre' ppr' mpmcfg)
 
@@ -85,7 +88,9 @@ evalInfo opts sgr m c info = do
       Just (L loc de) -> do de <- partEval opts gr (cont,val) de
                             return (Just (L loc (factor param c 0 de)))
       Nothing -> return pde
-    let ppr' = fmap (evalPrintname sgr c) ppr
+    ppr' <- case ppr of
+              Just pr -> fmap Just (evalPrintname sgr c pr)
+              Nothing -> return ppr
     return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
 {-
   ResOper pty pde
@@ -106,15 +111,16 @@ evalInfo opts sgr m c info = do
    eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
 
 -- | the main function for compiling linearizations
-partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
+partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Check Term
-partEval opts = {-if flag optNewComp opts
+partEval opts = error "TODO: partEval"
-                then-} partEvalNew opts
+                {-if flag optNewComp opts
+                then partEvalNew opts-}
                 {-else partEvalOld opts-}
-
+{-
 partEvalNew opts gr (context, val) trm =
     errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
     checkPredefError trm
-{-
+
 partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
   let vars  = map (\(bt,x,t) -> x) context
       args  = map Vr vars
@@ -148,7 +154,7 @@ recordExpand typ trm = case typ of
 -}
 -- | auxiliaries for compiling the resource
 
-mkLinDefault :: SourceGrammar -> Type -> Err Term
+mkLinDefault :: SourceGrammar -> Type -> Check Term
 mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
  where
    mkDefField typ = case typ of
@@ -157,23 +163,22 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
        let T _ cs = mkWildCases t'
        return $ T (TWild p) cs
      Sort s | s == cStr -> return $ Vr varStr
-     QC p           -> do vs <- lookupParamValues gr p
+     QC p           -> do case lookupParamValues gr p of
-                          case vs of
+                            Ok (v:_) -> return v
-                            v:_ -> return v
+                            _   -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
-                            _   -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
      RecType r  -> do
        let (ls,ts) = unzip r
        ts <- mapM mkDefField ts
        return $ R (zipWith assign ls ts)
      _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
-     _ -> Bad (render ("linearization type field cannot be" <+> typ))
+     _ -> checkError ("linearization type field cannot be" <+> typ)
 
-mkLinReference :: SourceGrammar -> Type -> Err Term
+mkLinReference :: SourceGrammar -> Type -> Check Term
 mkLinReference gr typ =
  liftM (Abs Explicit varStr) $
    case mkDefField typ (Vr varStr) of
      Bad "no string" -> return Empty
-     x               -> x
+     Ok x            -> return x
  where
    mkDefField ty trm =
      case ty of
@@ -190,8 +195,10 @@ mkLinReference gr typ =
        _ | Just _ <- isTypeInts typ -> Bad "no string"
        _ -> Bad (render ("linearization type field cannot be" <+> typ))
 
-evalPrintname :: Grammar -> Ident -> L Term -> L Term
+evalPrintname :: Grammar -> Ident -> L Term -> Check (L Term)
-evalPrintname gr c (L loc pr) = L loc (normalForm gr (L loc c) pr)
+evalPrintname gr c (L loc pr) = do
+  pr <- normalForm gr (L loc c) pr
+  return (L loc pr)
 
 -- do even more: factor parametric branches
 

src/compiler/GF/CompileOne.hs

@@ -107,7 +107,7 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- Apply to complete modules when not generating tags
     backend mo3 =
-      do mo4 <- runPassE Optimize "optimizing" $ optimizeModule opts gr mo3
+      do mo4 <- runPass Optimize "optimizing" $ optimizeModule opts gr mo3
          if isModCnc (snd mo4) && flag optPMCFG opts
           then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
           else runPassI "" $ return mo4
@@ -128,7 +128,6 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- * Running a compiler pass, with impedance matching
     runPass = runPass' fst fst snd (liftErr . runCheck' opts)
-    runPassE = runPass2e liftErr id
     runPassI = runPass2e id id Canon
     runPass2e lift dump = runPass' id dump (const "") lift
 

src/compiler/GF/Compiler.hs

@@ -15,6 +15,7 @@ import GF.Grammar.CFG
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 import GF.Infra.Option
+import GF.Infra.CheckM
 import GF.Data.ErrM
 import GF.System.Directory
 import GF.Text.Pretty(render,render80)
@@ -67,22 +68,25 @@ compileSourceFiles opts fs =
       where
         ofmts = flag optOutputFormats opts
 
-    cnc2haskell (cnc,gr) =
+    cnc2haskell (cnc,gr) = do
-      do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr
+      (res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr)
+      mapM_ writeExport res
 
-    abs2canonical (cnc,gr) =
+    abs2canonical (cnc,gr) = do
-        writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+      (canAbs,_) <- runCheck (abstract2canonical absname gr)
+      writeExport ("canonical/"++render absname++".gf",render80 canAbs)
       where
         absname = srcAbsName gr cnc
-        canAbs = abstract2canonical absname gr
 
-    cnc2canonical (cnc,gr) =
+    cnc2canonical (cnc,gr) = do
-      mapM_ (writeExport.fmap render80) $
+      (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
-            concretes2canonical opts (srcAbsName gr cnc) gr
+      mapM_ (writeExport.fmap render80) res
 
-    grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
+    grammar2json (cnc,gr) = do
-      where absname = srcAbsName gr cnc
+      (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
-            gr_canon = grammar2canonical opts absname gr
+      return (encodeJSON (render absname ++ ".json") gr_canon)
+      where
+        absname = srcAbsName gr cnc
 
     writeExport (path,s) = writing opts path $ writeUTF8File path s
 

src/compiler/GF/Grammar/Binary.hs

@@ -189,7 +189,6 @@ instance Binary Term where
   put (FV x)        = putWord8 32 >> put x
   put (Alts x y)    = putWord8 33 >> put (x,y)
   put (Strs x)      = putWord8 34 >> put x
-  put (Error x)     = putWord8 35 >> put x
 
   get = do tag <- getWord8
            case tag of
@@ -228,7 +227,6 @@ instance Binary Term where
              32 -> get >>= \x       -> return (FV x)
              33 -> get >>= \(x,y)   -> return (Alts x y)
              34 -> get >>= \x       -> return (Strs x)
-             35 -> get >>= \x       -> return (Error x)
              _  -> decodingError
 
 instance Binary Patt where

src/compiler/GF/Grammar/Grammar.hs

@@ -398,7 +398,6 @@ data Term =
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
- | Error String                  -- ^ error values returned by Predef.error
   deriving (Show, Eq, Ord)
 
 -- | Patterns

src/compiler/GF/Grammar/Macros.hs

@@ -238,12 +238,6 @@ isPredefConstant t = case t of
   Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
   _                                               -> False
 
-checkPredefError :: Fail.MonadFail m => Term -> m Term
-checkPredefError t =
-    case t of
-      Error s -> fail ("Error: "++s)
-      _ -> return t
-
 cnPredef :: Ident -> Term
 cnPredef f = Q (cPredef,f)
 

src/compiler/GF/Grammar/Printer.hs

@@ -240,7 +240,6 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
 ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
 
 ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 

src/compiler/GF/Infra/CheckM.hs

@@ -13,7 +13,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.CheckM
-          (Check, CheckResult, Message, runCheck, runCheck',
+          (Check, CheckResult(..), Message, runCheck, runCheck',
            checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
            checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,

src/compiler/GF/Infra/SIO.hs

@@ -24,12 +24,14 @@ import Control.Applicative(Applicative(..))
 import Control.Monad(liftM,ap)
 import Control.Monad.Trans(MonadTrans(..))
 import System.IO(hPutStr,hFlush,stdout)
+import System.IO.Error(isUserError,ioeGetErrorString)
 import GF.System.Catch(try)
 import System.Process(system)
 import System.Environment(getEnv)
 import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
 import GF.Infra.Concurrency(lazyIO)
 import GF.Infra.UseIO(Output(..))
+import GF.Data.Operations(ErrorMonad(..))
 import qualified System.CPUTime as IO(getCPUTime)
 import qualified System.Directory as IO(getCurrentDirectory)
 import qualified System.Random as IO(newStdGen)
@@ -37,6 +39,7 @@ import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 import qualified GF.Command.Importing as GF(importGrammar, importSource)
 import qualified Control.Monad.Fail as Fail
+import Control.Exception
 
 -- * The SIO monad
 
@@ -62,6 +65,14 @@ instance Output SIO where
   putStrLnE = putStrLnFlush
   putStrE = putStr
 
+instance ErrorMonad SIO where
+  raise = fail
+  handle m h = SIO $ \putStr ->
+                 catch (unS m putStr) $
+                    \e -> if isUserError e
+                            then unS (h (ioeGetErrorString e)) putStr
+                            else ioError e
+
 class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
 -- ^ If the Monad m superclass is included, then the generic instance
 -- for monad transformers below would require UndecidableInstances
@@ -96,7 +107,7 @@ restricted io    = SIO (const (restrictedIO io))
 restrictedSystem = restricted . system
 
 restrictedIO io =
-    either (const io) (const $ fail message) =<< try (getEnv "GF_RESTRICTED")
+    either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
   where
     message =
       "This operation is not allowed when GF is running in restricted mode."

testsuite/compiler/compute/predef.gfs.gold

@@ -23,9 +23,7 @@ Predef.PTrue
 Predef.PFalse
 Predef.PTrue
 5
-: In _: user error
+user error
-CallStack (from HasCallStack):
-  error, called at src/compiler/GF/Compile/Compute/Concrete.hs:36:18 in main:GF.Compile.Compute.Concrete
 "x" ++ Predef.nonExist ++ "y"
 "x" ++ Predef.BIND ++ "y"
 "x" ++ Predef.SOFT_BIND ++ "y"