Allow GhcModError as an Exception and catch it in GhcModT's liftIO
This commit is contained in:
parent
f55c264d67
commit
14ee81e300
@ -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 ->
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user