diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
index a7339748eb171c863b89e88ef4fc9e046c057c5b..69582cb392b0d8de8221eda6536b183889a1210f 100644
--- a/Cabal/Distribution/Simple/Configure.hs
+++ b/Cabal/Distribution/Simple/Configure.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Configure
@@ -24,6 +26,7 @@
module Distribution.Simple.Configure (configure,
writePersistBuildConfig,
+ getConfigStateFile,
getPersistBuildConfig,
checkPersistBuildConfigOutdated,
tryGetPersistBuildConfig,
@@ -35,9 +38,7 @@ module Distribution.Simple.Configure (configure,
ccLdOptionsBuildInfo,
checkForeignDeps,
interpretPackageDbFlags,
-
- ConfigStateFileErrorType(..),
- ConfigStateFileError,
+ ConfigStateFileError(..),
tryGetConfigStateFile,
platformDefines,
)
@@ -116,9 +117,11 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite
-- Prefer the more generic Data.Traversable.mapM to Prelude.mapM
import Prelude hiding ( mapM )
+import Control.Exception
+ ( ErrorCall(..), Exception, evaluate, throw, throwIO, try )
import Control.Monad
( liftM, when, unless, foldM, filterM )
-import Data.Binary ( Binary, decodeOrFail, encode )
+import Data.Binary ( decodeOrFail, encode )
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List
@@ -134,6 +137,7 @@ import qualified Data.Map as Map
import Data.Map (Map)
import Data.Traversable
( mapM )
+import Data.Typeable
import System.Directory
( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
import System.FilePath
@@ -149,83 +153,85 @@ import Text.PrettyPrint
, quotes, punctuate, nest, sep, hsep )
import Distribution.Compat.Exception ( catchExit, catchIO )
-data ConfigStateFileErrorType = ConfigStateFileCantParse
- | ConfigStateFileMissing
- | ConfigStateFileBadVersion
- deriving Eq
-type ConfigStateFileError = (String, ConfigStateFileErrorType)
-
-tryGetConfigStateFile :: (Binary a) => FilePath
- -> IO (Either ConfigStateFileError a)
-tryGetConfigStateFile filename = do
- exists <- doesFileExist filename
- if not exists
- then return missing
- else liftM decodeBody decodeHeader
- where
- decodeBody :: Binary a => Either ConfigStateFileError BS.ByteString
- -> Either ConfigStateFileError a
- decodeBody (Left err) = Left err
- decodeBody (Right body) =
- case decodeOrFail body of
- Left _ -> cantParseBody
- Right (_, _, x) -> Right x
-
- decodeHeader :: IO (Either ConfigStateFileError BS.ByteString)
- decodeHeader = do
- (header, body) <- liftM (BS.span $ (/=) '\n') $ BS.readFile filename
- return $ case parseHeader header of
- Nothing -> cantParseHeader
- Just (cabalId, compId)
- | (cabalId /= currentCabalId) || (compId /= currentCompilerId) ->
- badVersion cabalId compId
- | otherwise -> Right $ BS.tail body
-
- missing = Left ( "Run the 'configure' command first."
- , ConfigStateFileMissing )
- cantParseHeader = Left
- ( "Saved package config file header is corrupt."
+data ConfigStateFileError
+ = ConfigStateFileNoHeader
+ | ConfigStateFileBadHeader
+ | ConfigStateFileNoParse
+ | ConfigStateFileMissing
+ | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
+ deriving (Typeable)
+
+instance Show ConfigStateFileError where
+ show ConfigStateFileNoHeader =
+ "Saved package config file header is missing. "
+ ++ "Try re-running the 'configure' command."
+ show ConfigStateFileBadHeader =
+ "Saved package config file header is corrupt. "
++ "Try re-running the 'configure' command."
- , ConfigStateFileCantParse
- )
- cantParseBody = Left
- ( "Saved package config file body is corrupt."
+ show ConfigStateFileNoParse =
+ "Saved package config file body is corrupt. "
++ "Try re-running the 'configure' command."
- , ConfigStateFileCantParse
- )
- badVersion cabalId compId
- = Left ( "You need to re-run the 'configure' command. "
- ++ "The version of Cabal being used has changed (was "
- ++ display cabalId ++ ", now "
- ++ display currentCabalId ++ ")."
- ++ badcompiler compId
- , ConfigStateFileBadVersion )
- badcompiler compId | compId == currentCompilerId = ""
- | otherwise
- = " Additionally the compiler is different (was "
- ++ display compId ++ ", now "
- ++ display currentCompilerId
- ++ ") which is probably the cause of the problem."
+ show ConfigStateFileMissing = "Run the 'configure' command first."
+ show (ConfigStateFileBadVersion oldCabal oldCompiler _) =
+ "You need to re-run the 'configure' command. "
+ ++ "The version of Cabal being used has changed (was "
+ ++ display oldCabal ++ ", now "
+ ++ display currentCabalId ++ ")."
+ ++ badCompiler
+ where
+ badCompiler
+ | oldCompiler == currentCompilerId = ""
+ | otherwise =
+ " Additionally the compiler is different (was "
+ ++ display oldCompiler ++ ", now "
+ ++ display currentCompilerId
+ ++ ") which is probably the cause of the problem."
+
+instance Exception ConfigStateFileError
+
+getConfigStateFile :: FilePath -> IO LocalBuildInfo
+getConfigStateFile filename = do
+ exists <- doesFileExist filename
+ unless exists $ throwIO ConfigStateFileMissing
+
+ (header, body) <- liftM (BS.span $ (/=) '\n') $ BS.readFile filename
+
+ headerParseResult <- try $ evaluate $ parseHeader header
+ let (cabalId, compId) =
+ case headerParseResult of
+ Left (ErrorCall _) -> throw ConfigStateFileBadHeader
+ Right x -> x
+
+ let getStoredValue = evaluate $
+ case decodeOrFail (BS.tail body) of
+ Left _ -> throw ConfigStateFileNoParse
+ Right (_, _, x) -> x
+ deferErrorIfBadVersion act
+ | cabalId /= currentCabalId || compId /= currentCompilerId = do
+ eResult <- try act
+ throw $ ConfigStateFileBadVersion cabalId compId eResult
+ | otherwise = act
+ deferErrorIfBadVersion getStoredValue
+
+tryGetConfigStateFile :: FilePath
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetConfigStateFile = try . getConfigStateFile
-- |Try to read the 'localBuildInfoFile'.
tryGetPersistBuildConfig :: FilePath
- -> IO (Either ConfigStateFileError LocalBuildInfo)
-tryGetPersistBuildConfig distPref
- = tryGetConfigStateFile (localBuildInfoFile distPref)
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetPersistBuildConfig = try . getPersistBuildConfig
--- |Read the 'localBuildInfoFile'. Error if it doesn't exist. Also
--- fail if the file containing LocalBuildInfo is older than the .cabal
--- file, indicating that a re-configure is required.
+-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
+-- missing, if the file cannot be read, or if the file was created by an older
+-- version of Cabal.
getPersistBuildConfig :: FilePath -> IO LocalBuildInfo
-getPersistBuildConfig distPref = do
- lbi <- tryGetPersistBuildConfig distPref
- either (die . fst) return lbi
+getPersistBuildConfig = getConfigStateFile . localBuildInfoFile
-- |Try to read the 'localBuildInfoFile'.
maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)
-maybeGetPersistBuildConfig distPref = do
- lbi <- tryGetPersistBuildConfig distPref
- return $ either (const Nothing) Just lbi
+maybeGetPersistBuildConfig =
+ liftM (either (const Nothing) Just) . tryGetPersistBuildConfig
-- |After running configure, output the 'LocalBuildInfo' to the
-- 'localBuildInfoFile'.
@@ -244,14 +250,15 @@ currentCompilerId :: PackageIdentifier
currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)
System.Info.compilerVersion
-parseHeader :: ByteString -> Maybe (PackageIdentifier, PackageIdentifier)
+parseHeader :: ByteString -> (PackageIdentifier, PackageIdentifier)
parseHeader header = case BS.words header of
- ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] -> do
- _ <- simpleParse (BS.unpack pkgId) :: Maybe PackageIdentifier
- cabalId' <- simpleParse (BS.unpack cabalId)
- compId' <- simpleParse (BS.unpack compId)
- return (cabalId', compId')
- _ -> Nothing
+ ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] ->
+ fromMaybe (throw ConfigStateFileBadHeader) $ do
+ _ <- simpleParse (BS.unpack pkgId) :: Maybe PackageIdentifier
+ cabalId' <- simpleParse (BS.unpack cabalId)
+ compId' <- simpleParse (BS.unpack compId)
+ return (cabalId', compId')
+ _ -> throw ConfigStateFileNoHeader
showHeader :: PackageIdentifier -> ByteString
showHeader pkgId = BS.unwords
diff --git a/Cabal/tests/PackageTests.hs b/Cabal/tests/PackageTests.hs
index b3f50705d2543ecb56eb68b5246a7534f6fcc143..b2a599146ac5e756f6da786290556e36261ea8fb 100644
--- a/Cabal/tests/PackageTests.hs
+++ b/Cabal/tests/PackageTests.hs
@@ -36,21 +36,21 @@ import PackageTests.TestSuiteExeV10.Check
import PackageTests.OrderFlags.Check
import PackageTests.ReexportedModules.Check
-import Distribution.Package (PackageIdentifier)
+import Distribution.Simple.Configure
+ ( ConfigStateFileError(..), getConfigStateFile )
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Program.Types (programPath)
-import Distribution.Simple.Program.Builtin (ghcProgram, ghcPkgProgram,
- haddockProgram)
+import Distribution.Simple.Program.Builtin
+ ( ghcProgram, ghcPkgProgram, haddockProgram )
import Distribution.Simple.Program.Db (requireProgram)
-import Distribution.Simple.Utils (cabalVersion, die)
+import Distribution.Simple.Utils (cabalVersion)
import Distribution.Text (display)
import Distribution.Verbosity (normal)
import Distribution.Version (Version(Version))
-import Data.Binary (Binary, decodeOrFail)
-import qualified Data.ByteString.Lazy as BS
-import System.Directory (doesFileExist, getCurrentDirectory,
- setCurrentDirectory)
+import Control.Exception (try, throw)
+import System.Directory
+ ( getCurrentDirectory, setCurrentDirectory )
import System.FilePath ((</>))
import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)
import Test.Framework (Test, TestName, defaultMain, testGroup)
@@ -169,30 +169,9 @@ main = do
-- we run Cabal's own test suite, due to bootstrapping issues.
getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo
getPersistBuildConfig_ filename = do
- exists <- doesFileExist filename
- if not exists
- then die "Run the 'configure' command first."
- else decodeBinHeader >>= decodeBody
-
- where
- decodeB :: Binary a => BS.ByteString -> Either String (BS.ByteString, a)
- decodeB str = either (const cantParse) return $ do
- (next, _, x) <- decodeOrFail str
- return (next, x)
-
- decodeBody :: Either String BS.ByteString -> IO LocalBuildInfo
- decodeBody (Left msg) = die msg
- decodeBody (Right body) = either die (return . snd) $ decodeB body
-
- decodeBinHeader :: IO (Either String BS.ByteString)
- decodeBinHeader = do
- pbc <- BS.readFile filename
- return $ do
- (body, _) <- decodeB pbc :: Either String ( BS.ByteString
- , ( PackageIdentifier
- , PackageIdentifier )
- )
- return body
-
- cantParse = Left $ "Saved package config file seems to be corrupt. "
- ++ "Try re-running the 'configure' command."
+ eLBI <- try $ getConfigStateFile filename
+ case eLBI of
+ Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return lbi
+ Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err
+ Left err -> throw err
+ Right lbi -> return lbi
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
index ea04c9b76edfdd9cb7d151f68b924366d385c64e..e2c29940cd4f9eb591b090e0e5d221d47cfaeb42 100644
--- a/cabal-install/Main.hs
+++ b/cabal-install/Main.hs
@@ -125,7 +125,7 @@ import Distribution.Simple.Compiler
( Compiler(..) )
import Distribution.Simple.Configure
( checkPersistBuildConfigOutdated, configCompilerAuxEx
- , ConfigStateFileErrorType(..), localBuildInfoFile
+ , ConfigStateFileError(..), localBuildInfoFile
, getPersistBuildConfig, tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Program (defaultProgramConfiguration)
@@ -468,8 +468,8 @@ reconfigure verbosity distPref addConfigFlags extraArgs globalFlags
skipAddSourceDepsCheck numJobsFlag checkFlags = do
eLbi <- tryGetPersistBuildConfig distPref
case eLbi of
- Left (err, errCode) -> onNoBuildConfig err errCode
- Right lbi -> onBuildConfig lbi
+ Left err -> onNoBuildConfig err
+ Right lbi -> onBuildConfig lbi
where
@@ -477,17 +477,16 @@ reconfigure verbosity distPref addConfigFlags extraArgs globalFlags
--
-- If we're in a sandbox: add-source deps don't have to be reinstalled
-- (since we don't know the compiler & platform).
- onNoBuildConfig :: String -> ConfigStateFileErrorType
- -> IO (UseSandbox, SavedConfig)
- onNoBuildConfig err errCode = do
- let msg = case errCode of
- ConfigStateFileMissing -> "Package has never been configured."
- ConfigStateFileCantParse -> "Saved package config file seems "
- ++ "to be corrupt."
- ConfigStateFileBadVersion -> err
- case errCode of
- ConfigStateFileBadVersion -> info verbosity msg
- _ -> do
+ onNoBuildConfig :: ConfigStateFileError -> IO (UseSandbox, SavedConfig)
+ onNoBuildConfig err = do
+ let msg = case err of
+ ConfigStateFileMissing -> "Package has never been configured."
+ ConfigStateFileNoParse -> "Saved package config file seems "
+ ++ "to be corrupt."
+ _ -> show err
+ case err of
+ ConfigStateFileBadVersion _ _ _ -> info verbosity msg
+ _ -> do
notice verbosity
$ msg ++ " Configuring with default flags." ++ configureManually
configureAction (defaultFlags, defaultConfigExFlags)