diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 2215ab9..1936eb1 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} module Language.Haskell.GhcMod.Error ( GhcModError(..) , gmeDoc @@ -10,6 +10,8 @@ module Language.Haskell.GhcMod.Error ( ) where import Control.Monad.Error (MonadError(..), Error(..)) +import Data.List +import Data.Typeable import Exception import Text.PrettyPrint @@ -18,6 +20,8 @@ data GhcModError = GMENoMsg | GMEString String -- ^ Some Error with a message. These are produced mostly by -- 'fail' calls on GhcModT. + | GMEIOException IOException + -- ^ IOExceptions captured by GhcModT's MonadIO instance | GMECabalConfigure GhcModError -- ^ Configuring a cabal project failed. | GMECabalFlags GhcModError @@ -25,7 +29,9 @@ data GhcModError = GMENoMsg | GMEProcess [String] GhcModError -- ^ Launching an operating system process failed. The first -- field is the command. - deriving (Eq,Show) + deriving (Eq,Show,Typeable) + +instance Exception GhcModError instance Error GhcModError where noMsg = GMENoMsg @@ -37,6 +43,8 @@ gmeDoc e = case e of text "Unknown error" GMEString msg -> text msg + GMEIOException ioe -> + text $ show ioe GMECabalConfigure msg -> text "cabal configure failed: " <> gmeDoc msg GMECabalFlags msg -> diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 4d26280..2e0cb4b 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad ( @@ -101,7 +102,6 @@ import Control.Monad.Journal.Class import Data.Maybe (fromJust, isJust) import Data.IORef (IORef, readIORef, writeIORef, newIORef) import System.Directory (getCurrentDirectory) -import System.IO.Error (tryIOError) ---------------------------------------------------------------- @@ -154,12 +154,29 @@ newtype GhcModT m a = GhcModT { instance MonadIO m => MonadIO (GhcModT m) where liftIO action = do - res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ tryIOError action + res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action case res of Right a -> return a - Left e -> case show e of - "" -> throwError $ noMsg - msg -> throwError $ strMsg msg + + Left e | isIOError e -> + throwError $ GMEIOException (fromEx e :: IOError) + Left e | isGhcModError e -> + throwError $ (fromEx e :: GhcModError) + Left e -> throw e + + where + fromEx :: Exception e => SomeException -> e + fromEx = fromJust . fromException + isIOError se = + case fromException se of + Just (_ :: IOError) -> True + Nothing -> False + + isGhcModError se = + case fromException se of + Just (_ :: GhcModError) -> True + Nothing -> False + instance MonadTrans (GhcModT) where lift = GhcModT . lift . lift . lift . lift