Remove withErrorHandler, use liftExceptions instead

This commit is contained in:
Daniel Gröber 2014-08-19 04:28:04 +02:00
parent 0fd8b9afd8
commit 1b5917c70e
7 changed files with 33 additions and 26 deletions

View File

@ -49,12 +49,12 @@ type CabalConfig = String
getConfig :: (MonadIO m, MonadError GhcModError m) getConfig :: (MonadIO m, MonadError GhcModError m)
=> Cradle => Cradle
-> m CabalConfig -> m CabalConfig
getConfig cradle = tryFix (liftMonadError (readFile path)) $ \_ -> getConfig cradle = tryFix (liftIOExceptions (readFile path)) $ \_ ->
rethrowError (GMECabalConfigure . gmeMsg) configure rethrowError (GMECabalConfigure . gmeMsg) configure
where where
prjDir = cradleRootDir cradle prjDir = cradleRootDir cradle
path = prjDir </> configPath path = prjDir </> configPath
configure = liftMonadError $ void $ configure = liftIOExceptions $ void $
withDirectory_ prjDir $ readProcess' "cabal" ["configure"] withDirectory_ prjDir $ readProcess' "cabal" ["configure"]

View File

@ -10,9 +10,9 @@ import Language.Haskell.GhcMod.DynFlags
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions)
, overrideGhcUserOptions)
import Language.Haskell.GhcMod.Target (setTargetFiles) import Language.Haskell.GhcMod.Target (setTargetFiles)
import Language.Haskell.GhcMod.Utils (liftExceptions)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -22,7 +22,7 @@ checkSyntax :: IOish m
=> [FilePath] -- ^ The target files. => [FilePath] -- ^ The target files.
-> GhcModT m String -> GhcModT m String
checkSyntax [] = return "" checkSyntax [] = return ""
checkSyntax files = withErrorHandler $ either id id <$> check files checkSyntax files = liftExceptions $ either id id <$> check files
---------------------------------------------------------------- ----------------------------------------------------------------
@ -47,7 +47,7 @@ expandTemplate :: IOish m
=> [FilePath] -- ^ The target files. => [FilePath] -- ^ The target files.
-> GhcModT m String -> GhcModT m String
expandTemplate [] = return "" expandTemplate [] = return ""
expandTemplate files = withErrorHandler $ either id id <$> expand files expandTemplate files = liftExceptions $ either id id <$> expand files
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -35,7 +35,6 @@ module Language.Haskell.GhcMod.Internal (
, GhcModLog , GhcModLog
-- * Monad utilities -- * Monad utilities
, runGhcModT' , runGhcModT'
, withErrorHandler
-- ** Accessing 'GhcModEnv' and 'GhcModState' -- ** Accessing 'GhcModEnv' and 'GhcModState'
, options , options
, cradle , cradle

View File

@ -18,7 +18,6 @@ module Language.Haskell.GhcMod.Monad (
-- * Monad utilities -- * Monad utilities
, runGhcModT , runGhcModT
, runGhcModT' , runGhcModT'
, withErrorHandler
-- ** Accessing 'GhcModEnv' and 'GhcModState' -- ** Accessing 'GhcModEnv' and 'GhcModState'
, gmsGet , gmsGet
, gmsPut , gmsPut
@ -100,8 +99,6 @@ import Control.Monad.Journal.Class
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr)
import System.Directory (getCurrentDirectory) import System.Directory (getCurrentDirectory)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -272,16 +269,6 @@ runGhcModT' r s a = do
runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s
return (res, w') return (res, w')
---------------------------------------------------------------- ----------------------------------------------------------------
withErrorHandler :: IOish m => GhcModT m a -> GhcModT m a
withErrorHandler = ghandle ignore
where
ignore :: IOish m => SomeException -> GhcModT m a
ignore e = liftIO $ do
hPrint stderr e
-- FIXME: should print NG
exitSuccess
-- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the -- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the
-- original 'HscEnv'. -- original 'HscEnv'.
withTempSession :: IOish m => GhcModT m a -> GhcModT m a withTempSession :: IOish m => GhcModT m a -> GhcModT m a

View File

@ -2,18 +2,21 @@ module Language.Haskell.GhcMod.Types where
import Data.List (intercalate) import Data.List (intercalate)
import qualified Data.Map as M import qualified Data.Map as M
import Control.Exception (SomeException)
import Control.Monad.Error (Error(..)) import Control.Monad.Error (Error(..))
import PackageConfig (PackageConfig) import PackageConfig (PackageConfig)
data GhcModError = GMENoMsg data GhcModError = GMENoMsg
-- ^ Unknown error -- ^ Unknown error
| GMEException SomeException
-- ^ Regular exception lifted by 'liftExceptions'
| GMEString { gmeMsg :: String } | GMEString { gmeMsg :: String }
-- ^ Some Error with a message. These are produced mostly by -- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT. -- 'fail' calls on GhcModT.
| GMECabalConfigure { gmeMsg :: String } | GMECabalConfigure { gmeMsg :: String }
-- ^ Configuring a cabal project failed. -- ^ Configuring a cabal project failed.
deriving (Eq,Show,Read) deriving (Show)
instance Error GhcModError where instance Error GhcModError where
noMsg = GMENoMsg noMsg = GMENoMsg

View File

@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Utils where
import MonadUtils (MonadIO, liftIO) import MonadUtils (MonadIO, liftIO)
import Exception (ExceptionMonad, gtry)
import Control.Exception import Control.Exception
import Control.Monad.Error (MonadError(..), Error(..)) import Control.Monad.Error (MonadError(..), Error(..))
import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Directory (getCurrentDirectory, setCurrentDirectory)
@ -9,7 +10,7 @@ import System.Process (readProcessWithExitCode)
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.IO (hPutStrLn, stderr) import System.IO (hPutStrLn, stderr)
import System.IO.Error (tryIOError) import System.IO.Error (tryIOError)
import Language.Haskell.GhcMod.Types
-- dropWhileEnd is not provided prior to base 4.5.0.0. -- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@ -53,11 +54,24 @@ tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
tryFix action fix = do tryFix action fix = do
action `catchError` \e -> fix e >> action action `catchError` \e -> fix e >> action
liftMonadError :: (MonadIO m, Error e, MonadError e m) => IO a -> m a -- | 'IOException's thrown in the computation passed to this function will be
liftMonadError action = do -- converted to 'MonadError' failures using 'throwError'.
liftIOExceptions :: (MonadIO m, Error e, MonadError e m) => IO a -> m a
liftIOExceptions action = do
res <- liftIO $ tryIOError action res <- liftIO $ tryIOError action
case res of case res of
Right a -> return a Right a -> return a
Left e -> case show e of Left e -> case show e of
"" -> throwError $ noMsg "" -> throwError $ noMsg
msg -> throwError $ strMsg msg msg -> throwError $ strMsg msg
-- | Exceptions thrown in the computation passed to this function will be
-- converted to 'MonadError' failures using 'throwError'.
liftExceptions :: (MonadIO m, ExceptionMonad m, MonadError GhcModError m)
=> m a
-> m a
liftExceptions action = do
res <- gtry action
case res of
Right a -> return a
Left e -> throwError $ GMEException e

View File

@ -141,8 +141,12 @@ main = flip E.catches handlers $ do
cmd -> E.throw (NoSuchCommand cmd) cmd -> E.throw (NoSuchCommand cmd)
case res of case res of
Right s -> putStr s Right s -> putStr s
Left (GMENoMsg) -> hPutStrLn stderr "Unknown error" Left (GMEException e) ->
Left (GMEString msg) -> hPutStrLn stderr msg hPutStrLn stderr $ "Exception: " ++ show e
Left (GMENoMsg) ->
hPutStrLn stderr "Unknown error"
Left (GMEString msg) ->
hPutStrLn stderr msg
Left (GMECabalConfigure msg) -> Left (GMECabalConfigure msg) ->
hPutStrLn stderr $ "cabal configure failed: " ++ msg hPutStrLn stderr $ "cabal configure failed: " ++ msg
where where