Error -> Except

Author: egisatoshi

hs-src/Interpreter/egison.hs

@@ -2,7 +2,7 @@ module Main where
 
 import Prelude hiding (catch)
 import Control.Exception ( AsyncException(..), catch )
-import Control.Monad.Error
+import Control.Monad.Except
 
 import qualified Data.Text as T
 import Data.Char

hs-src/Language/Egison/Core.hs

@@ -43,7 +43,7 @@ import Prelude hiding (mapM, mappend)
 
 import Control.Arrow
 import Control.Applicative
-import Control.Monad.Error hiding (mapM)
+import Control.Monad.Except hiding (mapM)
 import Control.Monad.State hiding (mapM, state)
 import Control.Monad.Trans.Maybe
 import qualified Control.Monad.Parallel as MP
@@ -127,8 +127,8 @@ evalTopExprsNoIO env exprs = do
   collectDefs (expr:exprs) bindings rest =
     case expr of
       Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest
-      Load _ -> throwError $ strMsg "No IO support"
-      LoadFile _ -> throwError $ strMsg "No IO support"
+      Load _ -> throwError $ Default "No IO support"
+      LoadFile _ -> throwError $ Default "No IO support"
       _ -> collectDefs exprs bindings (expr : rest)
   collectDefs [] bindings rest = return (bindings, reverse rest)
 
@@ -479,7 +479,7 @@ evalExpr env (MatchExpr target matcher clauses) = do
             case result of
               MCons bindings _ -> evalExpr (extendEnv env bindings) expr
               MNil -> cont
-      foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses
+      foldr tryMatchClause (throwError $ Default "failed pattern match") clauses
 
 evalExpr env (SeqExpr expr1 expr2) = do
   evalExprDeep env expr1
@@ -989,7 +989,7 @@ processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)
   let env' = extendEnvForNonLinearPatterns env bindings loops
   case pattern of
     NotPat _ -> throwError $ EgisonBug "should not reach here (not pattern)"
-    VarPat _ -> throwError $ strMsg $ "cannot use variable except in pattern function:" ++ show pattern
+    VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern
 
     LetPat bindings' pattern' ->
       let extractBindings ([name], expr) =
@@ -1032,7 +1032,7 @@ processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)
           return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)
     ContPat ->
       case loops of
-        [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern"
+        [] -> throwError $ Default "cannot use cont pattern except in loop pattern"
         LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do
           startNumWhnf <- evalRef startNumRef
           startNum <- fromWHNF startNumWhnf :: (EgisonM Integer)
@@ -1078,7 +1078,7 @@ processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)
               if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return ()
               let trees' = zipWith3 MAtom patterns targets matchers ++ trees
               return $ msingleton $ MState env loops bindings trees'
-            _ ->  throwError $ strMsg $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern
+            _ ->  throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern
 
         Something ->
           case pattern of
@@ -1114,18 +1114,18 @@ processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)
                   keys <- return $ HL.keys hash
                   vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash
                   updateHash indices (Intermediate $ IIntHash $ HL.fromList $ zip keys vals)
-                updateHash _ v = throwError $ strMsg $ "expected hash value: " ++ show v
+                updateHash _ v = throwError $ Default $ "expected hash value: " ++ show v
                 subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)]
                 subst k nv ((k', v'):xs) | k == k'   = (k', nv):(subst k nv xs)
                                          | otherwise = (k', v'):(subst k nv xs)
                 subst _ _ [] = []
-            IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) 
+            IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern) 
             TuplePat patterns -> do
               targets <- fromTupleWHNF target
               if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()
               let trees' = zipWith3 MAtom patterns targets (take (length patterns) (repeat Something)) ++ trees
               return $ msingleton $ MState env loops bindings trees'
-            _ -> throwError $ strMsg "something can only match with a pattern variable"
+            _ -> throwError $ Default "something can only match with a pattern variable"
         _ ->  throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern
 
 inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher ->
@@ -1149,8 +1149,8 @@ inductiveMatch env pattern target (UserMatcher matcherEnv _ clauses) = do
               evalExpr env expr >>= fromCollection
             _ -> cont
       _ -> cont
-  failPPPatternMatch = throwError $ strMsg "failed primitive pattern pattern match"
-  failPDPatternMatch = throwError $ strMsg "failed primitive data pattern match"
+  failPPPatternMatch = throwError $ Default "failed primitive pattern pattern match"
+  failPDPatternMatch = throwError $ Default "failed primitive data pattern match"
 
 primitivePatPatternMatch :: Env -> PrimitivePatPattern -> EgisonPattern ->
                             MatchM ([EgisonPattern], [Binding])

hs-src/Language/Egison/Desugar.hs

@@ -25,17 +25,17 @@ import qualified Data.Set as S
 import Data.List (span)
 import Data.Set (Set)
 import Data.Char (toUpper)
-import Control.Monad.Error
+import Control.Monad.Except
 import Control.Monad.Reader
 import Language.Egison.Types
 
 type Subst = [(String, EgisonExpr)]
 
-newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ErrorT EgisonError Fresh) a }
+newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ExceptT EgisonError Fresh) a }
   deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst)
 
 runDesugarM :: DesugarM a -> Fresh (Either EgisonError a)
-runDesugarM = runErrorT . flip runReaderT [] . unDesugarM
+runDesugarM = runExceptT . flip runReaderT [] . unDesugarM
 
 desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr
 desugarTopExpr (Define name expr) = do

hs-src/Language/Egison/Parser.hs

@@ -26,7 +26,7 @@ module Language.Egison.Parser
 
 import Prelude hiding (mapM)
 import Control.Monad.Identity hiding (mapM)
-import Control.Monad.Error hiding (mapM)
+import Control.Monad.Except hiding (mapM)
 import Control.Monad.State hiding (mapM)
 import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)
 
@@ -98,7 +98,7 @@ loadLibraryFile file =
 loadFile :: FilePath -> EgisonM [EgisonTopExpr]
 loadFile file = do
   doesExist <- liftIO $ doesFileExist file
-  unless doesExist $ throwError $ strMsg ("file does not exist: " ++ file)
+  unless doesExist $ throwError $ Default ("file does not exist: " ++ file)
   input <- liftIO $ readFile file
   exprs <- readTopExprs $ shebang input
   concat <$> mapM  recursiveLoad exprs

hs-src/Language/Egison/Primitives.hs

@@ -11,7 +11,7 @@ This module provides primitive functions in Egison.
 module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where
 
 import Control.Arrow
-import Control.Monad.Error
+import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)
 

hs-src/Language/Egison/Types.hs

@@ -149,7 +149,7 @@ import Control.Exception
 import Data.Typeable
 
 import Control.Applicative
-import Control.Monad.Error
+import Control.Monad.Except
 import Control.Monad.State
 import Control.Monad.Reader (ReaderT)
 import Control.Monad.Writer (WriterT)
@@ -745,7 +745,7 @@ tIntRef' i (Tensor (n:ns) xs js) =
         let ys = V.take w (V.drop (w * (fromIntegral (i - 1))) xs) in
           fromTensor $ Tensor ns ys (cdr js)
    else throwError $ TensorIndexOutOfBounds i n
-tIntRef' i _ = throwError $ strMsg "More indices than the order of the tensor"
+tIntRef' i _ = throwError $ Default "More indices than the order of the tensor"
 
 tIntRef :: HasTensor a => [Integer] -> (Tensor a) -> EgisonM (Tensor a)
 tIntRef [] (Tensor [] xs _)
@@ -796,7 +796,7 @@ tref (s:ms) (Tensor (n:ns) xs js) = do
   let yss = split (product ns) xs
   ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss
   mapM toTensor ts >>= tConcat s >>= fromTensor
-tref _ t = throwError $ strMsg "More indices than the order of the tensor"
+tref _ t = throwError $ Default "More indices than the order of the tensor"
 
 enumTensorIndices :: [Integer] -> [[Integer]]
 enumTensorIndices [] = [[]]
@@ -1043,7 +1043,7 @@ tClearIndex' js = reverse (g (reverse js))
 
 getScalar :: (Tensor a) -> EgisonM a
 getScalar (Scalar x) = return x
-getScalar _ = throwError $ strMsg "Inconsitent Tensor order"
+getScalar _ = throwError $ Default "Inconsitent Tensor order"
 
 findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)]
 findPairs p xs = reverse $ findPairs' 0 p xs
@@ -1545,10 +1545,6 @@ instance Show EgisonError where
 
 instance Exception EgisonError
 
-instance Error EgisonError where
-  noMsg = Default "An error has occurred"
-  strMsg = Default
-
 liftError :: (MonadError e m) => Either e a -> m a
 liftError = either throwError return
 
@@ -1557,15 +1553,15 @@ liftError = either throwError return
 --
 
 newtype EgisonM a = EgisonM {
-    unEgisonM :: (ErrorT EgisonError (FreshT IO) a)
+    unEgisonM :: (ExceptT EgisonError (FreshT IO) a)
   } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh, MP.MonadParallel)
 --  } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh)
 
 runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a)
-runEgisonM = runErrorT . unEgisonM
+runEgisonM = runExceptT . unEgisonM
 
 liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a
-liftEgisonM m = EgisonM $ ErrorT $ FreshT $ do
+liftEgisonM m = EgisonM $ ExceptT $ FreshT $ do
   s <- get
   (a, s') <- return $ runFresh s m
   put s'
@@ -1614,7 +1610,7 @@ instance (MonadState s m) => MonadState s (FreshT m) where
 instance (MonadFresh m) => MonadFresh (StateT s m) where
   fresh = lift $ fresh
 
-instance (MonadFresh m, Error e) => MonadFresh (ErrorT e m) where
+instance (MonadFresh m) => MonadFresh (ExceptT e m) where
   fresh = lift $ fresh
 
 instance (MonadFresh m, Monoid e) => MonadFresh (ReaderT e m) where
@@ -1626,7 +1622,6 @@ instance (MonadFresh m, Monoid e) => MonadFresh (WriterT e m) where
 instance MonadIO (FreshT IO) where
   liftIO = lift
 
-instance (MP.MonadParallel m, Error e) => MP.MonadParallel (ErrorT e m)
 instance (MP.MonadParallel m) => MP.MonadParallel (StateT s m)
 
 runFreshT :: Monad m => (Int, Int) -> FreshT m a -> m (a, (Int, Int))

hs-src/Language/Egison/Util.hs

@@ -11,7 +11,7 @@ module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgis
 import Data.List
 import Text.Regex.TDFA
 import System.Console.Haskeline hiding (handle, catch, throwTo)
-import Control.Monad.Error (liftIO)
+import Control.Monad.Except (liftIO)
 
 import Language.Egison.Types
 import Language.Egison.Parser