Catch cabal configure failure properly

This commit is contained in:
Daniel Gröber 2014-08-18 08:06:36 +02:00
parent 6fec1de4b3
commit 271ff4e162
11 changed files with 90 additions and 30 deletions

View File

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

View File

@ -19,14 +19,15 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18
#define MIN_VERSION_mtl(x,y,z) 1 #define MIN_VERSION_mtl(x,y,z) 1
#endif #endif
import qualified Control.Exception as E import MonadUtils (MonadIO(liftIO))
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (mplus) import Control.Monad (mplus,void)
#if MIN_VERSION_mtl(2,2,1) #if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except () import Control.Monad.Except ()
#else #else
import Control.Monad.Error () import Control.Monad.Error ()
#endif #endif
import Control.Monad.Error (MonadError(..))
import Data.Maybe () import Data.Maybe ()
import Data.Set () import Data.Set ()
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) 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 -- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
-- exist run @cabal configure@ i.e. configure with default options like @cabal -- exist run @cabal configure@ i.e. configure with default options like @cabal
-- build@ would do. -- 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 where
prjDir = cradleRootDir cradle prjDir = cradleRootDir cradle
path = prjDir </> configPath 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@ -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
@ -59,7 +62,10 @@ configPath :: FilePath
configPath = localBuildInfoFile defaultDistPref configPath = localBuildInfoFile defaultDistPref
-- | Get list of 'Package's needed by all components of the current package -- | 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 = cabalConfigDependencies cradle thisPkg =
configDependencies thisPkg <$> getConfig cradle configDependencies thisPkg <$> getConfig cradle

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1,6 +1,9 @@
module UtilsSpec where module UtilsSpec where
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import System.IO.Error
import Control.Exception
import TestUtils
import Test.Hspec import Test.Hspec
spec :: Spec spec :: Spec
@ -9,3 +12,11 @@ spec = do
it "extracts the part of a string surrounded by parentheses" $ do it "extracts the part of a string surrounded by parentheses" $ do
extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )" 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\")]" 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 ""