Merge pull request #329 from DanielG/dev-error

Remove `withErrorHandler`, use `liftExceptions` instead

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"]
 
 

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
 
 ----------------------------------------------------------------
 
@@ -43,7 +43,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
 
 ----------------------------------------------------------------
 

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

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

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

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

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