73 lines
2.8 KiB
Haskell
73 lines
2.8 KiB
Haskell
module Stackage.CheckPlan
|
|
( checkPlan
|
|
) where
|
|
|
|
import Control.Monad (unless, when)
|
|
import Data.List (isPrefixOf, sort)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Stackage.CheckCabalVersion (checkCabalVersion)
|
|
import Stackage.InstallInfo
|
|
import Stackage.Types
|
|
import Stackage.Util
|
|
import System.Exit (ExitCode (ExitFailure, ExitSuccess),
|
|
exitWith)
|
|
import System.Process (readProcessWithExitCode)
|
|
|
|
data Mismatch = OnlyDryRun String | OnlySimpleList String
|
|
deriving Show
|
|
|
|
checkPlan :: BuildSettings -> BuildPlan -> IO ()
|
|
checkPlan settings bp = do
|
|
_ <- checkCabalVersion
|
|
|
|
putStrLn "Checking build plan"
|
|
packages <- mapM (replaceTarball $ tarballDir settings) (bpPackageList bp)
|
|
(ec, dryRun', stderr) <- readProcessWithExitCode "cabal"
|
|
( addCabalArgsOnlyGlobal settings
|
|
$ "install"
|
|
: "--dry-run"
|
|
: "--max-backjumps=-1"
|
|
: "--reorder-goals"
|
|
: packages
|
|
) ""
|
|
when (ec /= ExitSuccess || "Warning:" `isPrefixOf` stderr) $ do
|
|
putStr stderr
|
|
putStr dryRun'
|
|
putStrLn "cabal returned a bad result, exiting"
|
|
exitWith ec
|
|
let dryRun = sort $ filter notOptionalCore $ map (takeWhile (/= ' ')) $ drop 2 $ lines dryRun'
|
|
let mismatches = getMismatches dryRun (filter notOptionalCore $ bpPackageList bp)
|
|
unless (null $ filter (not . acceptableMismatch) mismatches) $ do
|
|
putStrLn "Found the following mismatches"
|
|
mapM_ print mismatches
|
|
exitWith $ ExitFailure 1
|
|
putStrLn "Build plan checked, no mismatches"
|
|
where
|
|
optionalCore = Set.fromList $ map packageVersionString $ Map.toList $ bpOptionalCore bp
|
|
notOptionalCore s = not $ s `Set.member` optionalCore
|
|
|
|
getMismatches :: [String] -> [String] -> [Mismatch]
|
|
getMismatches =
|
|
go
|
|
where
|
|
go [] y = map OnlySimpleList y
|
|
go x [] = map OnlyDryRun x
|
|
go (x:xs) (y:ys) =
|
|
case compare x y of
|
|
EQ -> go xs ys
|
|
LT -> OnlyDryRun x : go xs (y:ys)
|
|
GT -> OnlySimpleList y : go (x:xs) ys
|
|
|
|
-- | Some mismatches are going to be acceptable. The reasons are described
|
|
-- below.
|
|
acceptableMismatch :: Mismatch -> Bool
|
|
acceptableMismatch m =
|
|
case m of
|
|
-- GHC 7.4 included extensible-extensions as a core package, and
|
|
-- therefore the HP at time of writing (2012.4.0.0) includes it in that
|
|
-- list. However, GHC 7.6 does /not/ include that package. As a result,
|
|
-- we get that package included in the dry run but not our list of
|
|
-- packages to build. See issue #57.
|
|
OnlyDryRun s | "extensible-exceptions-" `isPrefixOf` s -> True
|
|
_ -> False
|