Catch cabal configure failure properly

Language/Haskell/GhcMod/Utils.hs

@@ -1,11 +1,15 @@
 module Language.Haskell.GhcMod.Utils where
 
+
 import MonadUtils (MonadIO, liftIO)
-import Control.Exception (bracket)
+import Control.Exception
+import Control.Monad.Error (MonadError(..), Error(..))
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import System.Process (readProcessWithExitCode)
 import System.Exit (ExitCode(..))
 import System.IO (hPutStrLn, stderr)
+import System.IO.Error (tryIOError)
+
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@@ -23,13 +27,17 @@ extractParens str = extractParens' str 0
        | s `elem` "}])" = s : extractParens' ss (level-1)
        | otherwise = s : extractParens' ss level
 
-readProcess' :: MonadIO m => String -> [String] -> m String
+readProcess' :: (MonadIO m, Error e, MonadError e m)
+             => String
+             -> [String]
+             -> m String
 readProcess' cmd opts = do
   (rv,output,err) <- liftIO $ readProcessWithExitCode cmd opts ""
   case rv of
     ExitFailure val -> do
         liftIO $ hPutStrLn stderr err
-        fail $ cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
+        throwError $ strMsg $
+          cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
     ExitSuccess ->
         return output
 
@@ -37,3 +45,19 @@ withDirectory_ :: FilePath -> IO a -> IO a
 withDirectory_ dir action =
     bracket getCurrentDirectory setCurrentDirectory
                 (\_ -> setCurrentDirectory dir >> action)
+
+rethrowError :: MonadError e m => (e -> e) -> m a -> m a
+rethrowError f action = action `catchError` \e -> throwError $ f e
+
+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
+  res <- liftIO $ tryIOError action
+  case res of
+    Right a -> return a
+    Left e -> case show e of
+                ""  -> throwError $ noMsg
+                msg -> throwError $ strMsg msg