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 :: (MonadIO m, MonadError GhcModError m)
-getConfig cradle =
+          => Cradle
-    readFile path `E.catch` (\(E.SomeException _) -> configure >> readFile path)
+          -> m CabalConfig
+getConfig cradle = tryFix (liftMonadError (readFile path)) $ \_ ->
+    rethrowError (GMECabalConfigure . gmeMsg) configure
  where
    prjDir = cradleRootDir cradle
    path = prjDir </> configPath
-   configure =
+   configure = liftMonadError $ void $
-     withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
+       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

ghc-mod.cabal

@@ -141,6 +141,7 @@ Executable ghc-modi
                       , containers
                       , directory
                       , filepath
+                      , split
                       , ghc
                       , ghc-mod
 

src/GHCMod.hs

@@ -143,6 +143,8 @@ main = flip E.catches handlers $ do
       Right s -> putStr s
       Left (GMENoMsg) -> hPutStrLn stderr "Unknown error"
       Left (GMEString msg) -> hPutStrLn stderr msg
+      Left (GMECabalConfigure msg) ->
+          hPutStrLn stderr $ "cabal configure failed: " ++ msg
   where
     handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
     handleThenExit handler e = handler e >> exitFailure

src/GHCModi.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
 
 -- Commands:
 --  check <file>
@@ -25,7 +25,8 @@ import Control.Exception (SomeException(..), Exception)
 import qualified Control.Exception as E
 import Control.Monad (when, void)
 import CoreMonad (liftIO)
-import Data.List (find)
+import Data.List (find, intercalate)
+import Data.List.Split (splitOn)
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
@@ -38,6 +39,7 @@ import System.Console.GetOpt
 import System.Directory (setCurrentDirectory)
 import System.Environment (getArgs)
 import System.IO (hFlush,stdout)
+import System.Exit (ExitCode, exitFailure)
 
 import Utils
 
@@ -93,7 +95,7 @@ main = E.handle cmdHandler $
     cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
     go (_,"help":_) = putStr $ usageInfo usage argspec
     go (_,"version":_) = putStr progVersion
-    go (opt,_) = E.handle someHandler $ do
+    go (opt,_) = flip E.catches handlers $ do
         cradle0 <- findCradle
         let rootdir = cradleRootDir cradle0
 --            c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
@@ -104,17 +106,29 @@ main = E.handle cmdHandler $
 
         case res of
           Right () -> return ()
-          Left e -> error $ show e
+          Left (GMECabalConfigure msg) -> do
+              putStrLn $ notGood $ "cabal configure failed: " ++ msg
+              exitFailure
+          Left e -> bug $ show e
       where
         -- this is just in case.
         -- If an error is caught here, it is a bug of GhcMod library.
-        someHandler (SomeException e) = do
+        handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
-            putStrLn $ "NG " ++ replace (show e)
+                   , E.Handler (\(SomeException e) -> bug $ show e) ]
 
-replace :: String -> String
+bug :: String -> IO ()
-replace [] = []
+bug msg = do
-replace ('\n':xs) = ';' : replace xs
+  putStrLn $ notGood $ "BUG: " ++ msg
-replace (x:xs)    =  x  : replace xs
+  exitFailure
+
+notGood :: String -> String
+notGood msg = "NG " ++ escapeNewlines msg
+
+escapeNewlines :: String -> String
+escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
+
+replace :: String -> String -> String -> String
+replace needle replacement = intercalate replacement . splitOn needle
 
 ----------------------------------------------------------------
 
@@ -147,7 +161,7 @@ loop set mvar = do
         liftIO $ putStr ret
         liftIO $ putStrLn "OK"
       else do
-        liftIO $ putStrLn $ "NG " ++ replace ret
+        liftIO $ putStrLn $ notGood ret
     liftIO $ hFlush stdout
     when ok $ loop set' mvar
 

test/CabalApiSpec.hs

@@ -34,7 +34,7 @@ spec = do
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
                 cradle <- findCradle
                 pkgDesc <- runD $ parseCabalFile $ fromJust $ cradleCabalFile cradle
-                res <- getCompilerOptions [] cradle pkgDesc
+                res <- runD $ getCompilerOptions [] cradle pkgDesc
                 let res' = res {
                         ghcOptions  = ghcOptions res
                       , includeDirs = map (toRelativeDir dir) (includeDirs res)

test/UtilsSpec.hs

@@ -1,6 +1,9 @@
 module UtilsSpec where
 
 import Language.Haskell.GhcMod.Utils
+import System.IO.Error
+import Control.Exception
+import TestUtils
 import Test.Hspec
 
 spec :: Spec
@@ -9,3 +12,11 @@ spec = do
         it "extracts the part of a string surrounded by parentheses" $ do
             extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )"
             extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]"
+
+    describe "liftMonadError" $ do
+        it "converts IOErrors to GhcModError" $ do
+            shouldReturnError $
+                runD' $ liftMonadError $ throw (userError "hello") >> return ""
+
+            shouldReturnError $
+                runD' $ liftMonadError $ readFile "/DOES_NOT_EXIST" >> return ""