From 69f3a1b8e79da8c2dd737f80960ee2a2ecf61fb5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 7 Dec 2014 12:36:25 +0200 Subject: [PATCH] Proper conditional tracking --- Stackage2/BuildPlan.hs | 26 ++++++++++---- Stackage2/PackageConstraints.hs | 6 ++++ Stackage2/PackageDescription.hs | 63 ++++++++++++++++++++++++++------- 3 files changed, 77 insertions(+), 18 deletions(-) diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index 3dd13d46..79d20570 100644 --- a/Stackage2/BuildPlan.hs +++ b/Stackage2/BuildPlan.hs @@ -28,6 +28,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Aeson import Stackage2.PackageDescription +import qualified Distribution.System +import qualified Distribution.Compiler data BuildPlan desc = BuildPlan { bpCore :: Map PackageName Version @@ -251,10 +253,25 @@ isAllowed core = \name version -> Nothing -> True -- no constraints Just (range, _) -> withinRange version range -mkPackageBuild :: Monad m +mkPackageBuild :: MonadThrow m => GenericPackageDescription -> m (PackageBuild FlatComponent) -mkPackageBuild gpd = +mkPackageBuild gpd = do + let overrides = packageFlags name ++ defaultGlobalFlags + getFlag MkFlag {..} = + (flagName, fromMaybe flagDefault $ lookup flagName overrides) + desc <- getFlattenedComponent + CheckCond + { ccPackageName = name + , ccOS = Distribution.System.Linux + , ccArch = Distribution.System.X86_64 + , ccCompilerFlavor = Distribution.Compiler.GHC + , ccCompilerVersion = ghcVerCabal + , ccFlags = mapFromList $ map getFlag $ genPackageFlags gpd + } + (tryBuildTest name) + (tryBuildBenchmark name) + gpd return PackageBuild { pbVersion = version , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints @@ -275,10 +292,7 @@ mkPackageBuild gpd = -> ExpectFailure | otherwise -> ExpectSuccess , pbTryBuildBenchmark = tryBuildBenchmark name - , pbDesc = getFlattenedComponent - (tryBuildTest name) - (tryBuildBenchmark name) - gpd + , pbDesc = desc } where PackageIdentifier name version = package $ packageDescription gpd diff --git a/Stackage2/PackageConstraints.hs b/Stackage2/PackageConstraints.hs index ede41f4a..f8c68757 100644 --- a/Stackage2/PackageConstraints.hs +++ b/Stackage2/PackageConstraints.hs @@ -9,6 +9,7 @@ module Stackage2.PackageConstraints , packageFlags , tryBuildTest , tryBuildBenchmark + , ghcVerCabal ) where import Stackage2.Prelude @@ -36,9 +37,14 @@ defaultPackageConstraints = PackageConstraints , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False } +-- FIXME below here shouldn't be so hard-coded + ghcVer :: Old.GhcMajorVersion ghcVer = Old.GhcMajorVersion 7 8 +ghcVerCabal :: Version +ghcVerCabal = Version [7, 8, 3] [] + oldSettings :: Old.SelectSettings oldSettings = Old.defaultSelectSettings ghcVer False diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index b228a060..68cdd650 100644 --- a/Stackage2/PackageDescription.hs +++ b/Stackage2/PackageDescription.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} @@ -11,6 +12,7 @@ module Stackage2.PackageDescription ( FlatComponent (..) , getFlattenedComponent , SimpleExtra (..) + , CheckCond (..) ) where import Distribution.Package (Dependency (..)) @@ -25,6 +27,8 @@ import Control.Monad.State.Strict (execState, get, put) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Aeson +import Distribution.System (OS, Arch) +import Distribution.Compiler (CompilerFlavor) data SimpleTree = SimpleTree { stDeps :: Map PackageName VersionRange @@ -51,12 +55,16 @@ instance Monoid SimpleExtra where (b ++ y) getFlattenedComponent - :: Bool -- ^ include test suites? + :: MonadThrow m + => CheckCond + -> Bool -- ^ include test suites? -> Bool -- ^ include benchmarks? -> GenericPackageDescription - -> FlatComponent -getFlattenedComponent includeTests includeBench gpd = - foldMap flattenComponent $ getSimpleTrees includeTests includeBench gpd + -> m FlatComponent +getFlattenedComponent checkCond' includeTests includeBench gpd = + liftM fold + $ mapM (flattenComponent checkCond') + $ getSimpleTrees includeTests includeBench gpd getSimpleTrees :: Bool -- ^ include test suites? -> Bool -- ^ include benchmarks? @@ -103,14 +111,45 @@ instance Monoid FlatComponent where (unionWith intersectVersionRanges a x) (b ++ y) -flattenComponent :: SimpleTree -> FlatComponent -flattenComponent (SimpleTree deps conds extra) = - mconcat $ here : map goCond conds +flattenComponent :: MonadThrow m => CheckCond -> SimpleTree -> m FlatComponent +flattenComponent checkCond' (SimpleTree deps conds extra) = do + conds' <- mapM goCond conds + return $ mconcat $ here : conds' where here = FlatComponent { fcDeps = deps, fcExtra = extra } - goCond (cond, tree1, mtree2) - | checkCond cond = flattenComponent tree1 - | otherwise = maybe mempty flattenComponent mtree2 + goCond (cond, tree1, mtree2) = do + b <- checkCond checkCond' cond + if b + then flattenComponent checkCond' tree1 + else maybe (return mempty) (flattenComponent checkCond') mtree2 -checkCond :: Condition ConfVar -> Bool -checkCond _ = False -- FIXME +checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool +checkCond CheckCond {..} cond0 = + go cond0 + where + go (Var (OS os)) = return $ os == ccOS + go (Var (Arch arch)) = return $ arch == ccArch + go (Var (Flag flag)) = + case lookup flag ccFlags of + Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0 + Just b -> return b + go (Var (Impl flavor range)) = return + $ flavor == ccCompilerFlavor + && ccCompilerVersion `withinRange` range + go (Lit b) = return b + go (CNot c) = not `liftM` go c + go (CAnd x y) = (&&) `liftM` go x `ap` go y + go (COr x y) = (||) `liftM` go x `ap` go y + +data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar) + deriving (Show, Typeable) +instance Exception CheckCondException + +data CheckCond = CheckCond + { ccPackageName :: PackageName -- for debugging only + , ccOS :: OS + , ccArch :: Arch + , ccFlags :: Map FlagName Bool + , ccCompilerFlavor :: CompilerFlavor + , ccCompilerVersion :: Version + }