Allow GhcModError as an Exception and catch it in GhcModT's liftIO

This commit is contained in:
Daniel Gröber 2014-10-31 22:23:48 +01:00
parent f55c264d67
commit 14ee81e300
2 changed files with 32 additions and 7 deletions

View File

@ -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 ->

View File

@ -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