diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 01c3484..83a7e1d 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -49,12 +49,12 @@ type CabalConfig = String getConfig :: (MonadIO m, MonadError GhcModError m) => Cradle -> m CabalConfig -getConfig cradle = tryFix (liftMonadError (readFile path)) $ \_ -> +getConfig cradle = tryFix (liftIOExceptions (readFile path)) $ \_ -> rethrowError (GMECabalConfigure . gmeMsg) configure where prjDir = cradleRootDir cradle path = prjDir configPath - configure = liftMonadError $ void $ + configure = liftIOExceptions $ void $ withDirectory_ prjDir $ readProcess' "cabal" ["configure"] diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 3d20e51..88ace61 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -10,9 +10,9 @@ import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import qualified GHC as G import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler - , overrideGhcUserOptions) +import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions) import Language.Haskell.GhcMod.Target (setTargetFiles) +import Language.Haskell.GhcMod.Utils (liftExceptions) ---------------------------------------------------------------- @@ -22,7 +22,7 @@ checkSyntax :: IOish m => [FilePath] -- ^ The target files. -> GhcModT m String 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. -> GhcModT m String expandTemplate [] = return "" -expandTemplate files = withErrorHandler $ either id id <$> expand files +expandTemplate files = liftExceptions $ either id id <$> expand files ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 9c9ef10..777749e 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -35,7 +35,6 @@ module Language.Haskell.GhcMod.Internal ( , GhcModLog -- * Monad utilities , runGhcModT' - , withErrorHandler -- ** Accessing 'GhcModEnv' and 'GhcModState' , options , cradle diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 5eaefef..f3207dc 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -18,7 +18,6 @@ module Language.Haskell.GhcMod.Monad ( -- * Monad utilities , runGhcModT , runGhcModT' - , withErrorHandler -- ** Accessing 'GhcModEnv' and 'GhcModState' , gmsGet , gmsPut @@ -100,8 +99,6 @@ import Control.Monad.Journal.Class import Data.Maybe (fromJust, isJust) import Data.IORef (IORef, readIORef, writeIORef, newIORef) -import System.Exit (exitSuccess) -import System.IO (hPutStr, hPrint, stderr) import System.Directory (getCurrentDirectory) ---------------------------------------------------------------- @@ -272,16 +269,6 @@ runGhcModT' r s a = do runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s 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 -- original 'HscEnv'. withTempSession :: IOish m => GhcModT m a -> GhcModT m a diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 1e80ca2..8313aae 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -2,18 +2,21 @@ module Language.Haskell.GhcMod.Types where import Data.List (intercalate) import qualified Data.Map as M +import Control.Exception (SomeException) import Control.Monad.Error (Error(..)) import PackageConfig (PackageConfig) data GhcModError = GMENoMsg -- ^ Unknown error + | GMEException SomeException + -- ^ Regular exception lifted by 'liftExceptions' | GMEString { gmeMsg :: String } -- ^ Some Error with a message. These are produced mostly by -- 'fail' calls on GhcModT. | GMECabalConfigure { gmeMsg :: String } -- ^ Configuring a cabal project failed. - deriving (Eq,Show,Read) + deriving (Show) instance Error GhcModError where noMsg = GMENoMsg diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 4adba59..30597f9 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Utils where import MonadUtils (MonadIO, liftIO) +import Exception (ExceptionMonad, gtry) import Control.Exception import Control.Monad.Error (MonadError(..), Error(..)) import System.Directory (getCurrentDirectory, setCurrentDirectory) @@ -9,7 +10,7 @@ import System.Process (readProcessWithExitCode) import System.Exit (ExitCode(..)) import System.IO (hPutStrLn, stderr) import System.IO.Error (tryIOError) - +import Language.Haskell.GhcMod.Types -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] @@ -53,11 +54,24 @@ tryFix :: MonadError e m => m a -> (e -> m ()) -> m a tryFix action fix = do action `catchError` \e -> fix e >> action -liftMonadError :: (MonadIO m, Error e, MonadError e m) => IO a -> m a -liftMonadError action = do +-- | 'IOException's thrown in the computation passed to this function will be +-- 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 case res of Right a -> return a Left e -> case show e of "" -> throwError $ noMsg 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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 4e9f4f7..41e9e38 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -141,8 +141,12 @@ main = flip E.catches handlers $ do cmd -> E.throw (NoSuchCommand cmd) case res of Right s -> putStr s - Left (GMENoMsg) -> hPutStrLn stderr "Unknown error" - Left (GMEString msg) -> hPutStrLn stderr msg + Left (GMEException e) -> + hPutStrLn stderr $ "Exception: " ++ show e + Left (GMENoMsg) -> + hPutStrLn stderr "Unknown error" + Left (GMEString msg) -> + hPutStrLn stderr msg Left (GMECabalConfigure msg) -> hPutStrLn stderr $ "cabal configure failed: " ++ msg where