From 14ee81e300e4619746256a8d242326dc71d13f52 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Fri, 31 Oct 2014 22:23:48 +0100
Subject: [PATCH] Allow GhcModError as an Exception and catch it in GhcModT's
 liftIO

---
 Language/Haskell/GhcMod/Error.hs | 12 ++++++++++--
 Language/Haskell/GhcMod/Monad.hs | 27 ++++++++++++++++++++++-----
 2 files changed, 32 insertions(+), 7 deletions(-)

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