Catch cabal configure failure properly

Language/Haskell/GhcMod/CabalApi.hs

@@ -42,12 +42,13 @@ import System.FilePath ((</>))
 ----------------------------------------------------------------
 
 -- | Getting necessary 'CompilerOptions' from three information sources.
-getCompilerOptions :: [GHCOption]
+getCompilerOptions :: (MonadIO m, MonadError GhcModError m, Functor m)
+                   => [GHCOption]
                    -> Cradle
                    -> PackageDescription
-                   -> IO CompilerOptions
+                   -> m CompilerOptions
 getCompilerOptions ghcopts cradle pkgDesc = do
-    gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos
+    gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos
     depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)
     return $ CompilerOptions gopts idirs depPkgs
   where

Language/Haskell/GhcMod/CabalConfig.hs

@@ -19,14 +19,15 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18
 #define MIN_VERSION_mtl(x,y,z) 1
 #endif
 
-import qualified Control.Exception as E
+import MonadUtils (MonadIO(liftIO))
 import Control.Applicative ((<$>))
-import Control.Monad (mplus)
+import Control.Monad (mplus,void)
 #if MIN_VERSION_mtl(2,2,1)
 import Control.Monad.Except ()
 #else
 import Control.Monad.Error ()
 #endif
+import Control.Monad.Error (MonadError(..))
 import Data.Maybe ()
 import Data.Set ()
 import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
@@ -44,14 +45,16 @@ type CabalConfig = String
 -- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
 -- exist run @cabal configure@ i.e. configure with default options like @cabal
 -- build@ would do.
-getConfig :: Cradle -> IO CabalConfig
-getConfig cradle =
-    readFile path `E.catch` (\(E.SomeException _) -> configure >> readFile path)
+getConfig :: (MonadIO m, MonadError GhcModError m)
+          => Cradle
+          -> m CabalConfig
+getConfig cradle = tryFix (liftMonadError (readFile path)) $ \_ ->
+    rethrowError (GMECabalConfigure . gmeMsg) configure
  where
    prjDir = cradleRootDir cradle
    path = prjDir </> configPath
-   configure =
-     withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
+   configure = liftMonadError $ void $
+       withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
 
 
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
@@ -59,7 +62,10 @@ configPath :: FilePath
 configPath = localBuildInfoFile defaultDistPref
 
 -- | Get list of 'Package's needed by all components of the current package
-cabalConfigDependencies :: Cradle -> PackageIdentifier -> IO [Package]
+cabalConfigDependencies :: (MonadIO m, Functor m, MonadError GhcModError m)
+                        => Cradle
+                        -> PackageIdentifier
+                        -> m [Package]
 cabalConfigDependencies cradle thisPkg =
     configDependencies thisPkg <$> getConfig cradle
 

Language/Haskell/GhcMod/Debug.hs

@@ -32,7 +32,7 @@ debugInfo = cradle >>= \c -> convert' =<< do
         return $ CompilerOptions (ghcUserOptions op) [] []
     fromCabalFile c = options >>= \opts -> do
         pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
-        liftIO $ getCompilerOptions (ghcUserOptions opts) c pkgDesc
+        getCompilerOptions (ghcUserOptions opts) c pkgDesc
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Monad.hs

@@ -204,7 +204,7 @@ initializeFlagsWithCradle opt c
     ghcopts = ghcUserOptions opt
     withCabal = do
         pkgDesc <- parseCabalFile $ fromJust mCradleFile
-        compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
+        compOpts <- getCompilerOptions ghcopts c pkgDesc
         initSession CabalPkg opt compOpts
     withSandbox = initSession SingleFile opt compOpts
       where

Language/Haskell/GhcMod/Types.hs

@@ -6,12 +6,13 @@ import Control.Monad.Error (Error(..))
 
 import PackageConfig (PackageConfig)
 
--- |
 data GhcModError = GMENoMsg
                  -- ^ Unknown error
-                 | GMEString String
+                 | GMEString { gmeMsg :: String }
                  -- ^ Some Error with a message. These are produced mostly by
                  -- 'fail' calls on GhcModT.
+                 | GMECabalConfigure { gmeMsg :: String }
+                 -- ^ Configuring a cabal project failed.
                    deriving (Eq,Show,Read)
 
 instance Error GhcModError where

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