Catch cabal configure
failure properly
This commit is contained in:
parent
6fec1de4b3
commit
271ff4e162
@ -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
|
||||||
|
@ -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,13 +45,15 @@ 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"]
|
||||||
|
|
||||||
|
|
||||||
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -141,6 +141,7 @@ Executable ghc-modi
|
|||||||
, containers
|
, containers
|
||||||
, directory
|
, directory
|
||||||
, filepath
|
, filepath
|
||||||
|
, split
|
||||||
, ghc
|
, ghc
|
||||||
, ghc-mod
|
, ghc-mod
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
@ -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 ""
|
||||||
|
Loading…
Reference in New Issue
Block a user