69f3a1b · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

Proper conditional tracking

69f3a1bMichael Snoyman12 years ago

Stackage2/BuildPlan.hs+20−6

compare with master

unifiedsplit

@@ -28,6 +28,8 @@ import qualified Data.Map as Map

28import qualified Data.Set as Set

29import Data.Aeson

30import Stackage2.PackageDescription

31+import qualified Distribution.System

32+import qualified Distribution.Compiler

32data BuildPlan desc = BuildPlan

34data BuildPlan desc = BuildPlan

33 { bpCore :: Map PackageName Version

35 { bpCore :: Map PackageName Version

@@ -251,10 +253,25 @@ isAllowed core = \name version ->

251 Nothing -> True -- no constraints

253 Nothing -> True -- no constraints

252 Just (range, _) -> withinRange version range

254 Just (range, _) -> withinRange version range

253

255

254−mkPackageBuild :: Monad m

256+mkPackageBuild :: MonadThrow m

255 => GenericPackageDescription

257 => GenericPackageDescription

256 -> m (PackageBuild FlatComponent)

258 -> m (PackageBuild FlatComponent)

257−mkPackageBuild gpd =

259+mkPackageBuild gpd = do

260+ let overrides = packageFlags name ++ defaultGlobalFlags

261+ getFlag MkFlag {..} =

262+ (flagName, fromMaybe flagDefault $ lookup flagName overrides)

263+ desc <- getFlattenedComponent

264+ CheckCond

265+ { ccPackageName = name

266+ , ccOS = Distribution.System.Linux

267+ , ccArch = Distribution.System.X86_64

268+ , ccCompilerFlavor = Distribution.Compiler.GHC

269+ , ccCompilerVersion = ghcVerCabal

270+ , ccFlags = mapFromList $ map getFlag $ genPackageFlags gpd

271+ }

272+ (tryBuildTest name)

273+ (tryBuildBenchmark name)

274+ gpd

258 return PackageBuild

275 return PackageBuild

259 { pbVersion = version

276 { pbVersion = version

260 , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints

277 , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints

@@ -275,10 +292,7 @@ mkPackageBuild gpd =

275 -> ExpectFailure

292 -> ExpectFailure

276 | otherwise -> ExpectSuccess

293 | otherwise -> ExpectSuccess

277 , pbTryBuildBenchmark = tryBuildBenchmark name

294 , pbTryBuildBenchmark = tryBuildBenchmark name

278− , pbDesc = getFlattenedComponent

295+ , pbDesc = desc

279− (tryBuildTest name)

280− (tryBuildBenchmark name)

281− gpd

282 }

296 }

283 where

297 where

284 PackageIdentifier name version = package $ packageDescription gpd

298 PackageIdentifier name version = package $ packageDescription gpd

Stackage2/PackageConstraints.hs+6

@@ -9,6 +9,7 @@ module Stackage2.PackageConstraints

9 , packageFlags

10 , tryBuildTest

11 , tryBuildBenchmark

12+ , ghcVerCabal

12 ) where

13 ) where

14import Stackage2.Prelude

15import Stackage2.Prelude

@@ -36,9 +37,14 @@ defaultPackageConstraints = PackageConstraints

36 , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False

37 , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False

37 }

38 }

40+-- FIXME below here shouldn't be so hard-coded

41+

39ghcVer :: Old.GhcMajorVersion

42ghcVer :: Old.GhcMajorVersion

40ghcVer = Old.GhcMajorVersion 7 8

43ghcVer = Old.GhcMajorVersion 7 8

45+ghcVerCabal :: Version

46+ghcVerCabal = Version [7, 8, 3] []

47+

42oldSettings :: Old.SelectSettings

48oldSettings :: Old.SelectSettings

43oldSettings = Old.defaultSelectSettings ghcVer False

49oldSettings = Old.defaultSelectSettings ghcVer False

Stackage2/PackageDescription.hs+51−12

@@ -1,4 +1,5 @@

1{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE DeriveFunctor #-}

5{-# LANGUAGE DeriveFunctor #-}

@@ -11,6 +12,7 @@ module Stackage2.PackageDescription

11 ( FlatComponent (..)

12 ( FlatComponent (..)

12 , getFlattenedComponent

13 , getFlattenedComponent

13 , SimpleExtra (..)

14 , SimpleExtra (..)

15+ , CheckCond (..)

14 ) where

16 ) where

16import Distribution.Package (Dependency (..))

18import Distribution.Package (Dependency (..))

@@ -25,6 +27,8 @@ import Control.Monad.State.Strict (execState, get, put)

25import qualified Data.Map as Map

27import qualified Data.Map as Map

26import qualified Data.Set as Set

28import qualified Data.Set as Set

27import Data.Aeson

29import Data.Aeson

30+import Distribution.System (OS, Arch)

31+import Distribution.Compiler (CompilerFlavor)

29data SimpleTree = SimpleTree

33data SimpleTree = SimpleTree

30 { stDeps :: Map PackageName VersionRange

34 { stDeps :: Map PackageName VersionRange

@@ -51,12 +55,16 @@ instance Monoid SimpleExtra where

51 (b ++ y)

55 (b ++ y)

53getFlattenedComponent

57getFlattenedComponent

58+ :: MonadThrow m

59+ => CheckCond

54− :: Bool -- ^ include test suites?

60+ -> Bool -- ^ include test suites?

55 -> Bool -- ^ include benchmarks?

61 -> Bool -- ^ include benchmarks?

56 -> GenericPackageDescription

62 -> GenericPackageDescription

57− -> FlatComponent

63+ -> m FlatComponent

58−getFlattenedComponent includeTests includeBench gpd =

64+getFlattenedComponent checkCond' includeTests includeBench gpd =

65+ liftM fold

66+ $ mapM (flattenComponent checkCond')

59− foldMap flattenComponent $ getSimpleTrees includeTests includeBench gpd

67+ $ getSimpleTrees includeTests includeBench gpd

61getSimpleTrees :: Bool -- ^ include test suites?

69getSimpleTrees :: Bool -- ^ include test suites?

62 -> Bool -- ^ include benchmarks?

70 -> Bool -- ^ include benchmarks?

@@ -103,14 +111,45 @@ instance Monoid FlatComponent where

103 (unionWith intersectVersionRanges a x)

111 (unionWith intersectVersionRanges a x)

104 (b ++ y)

112 (b ++ y)

105

113

106−flattenComponent :: SimpleTree -> FlatComponent

114+flattenComponent :: MonadThrow m => CheckCond -> SimpleTree -> m FlatComponent

107−flattenComponent (SimpleTree deps conds extra) =

115+flattenComponent checkCond' (SimpleTree deps conds extra) = do

116+ conds' <- mapM goCond conds

108− mconcat $ here : map goCond conds

117+ return $ mconcat $ here : conds'

109 where

118 where

110 here = FlatComponent { fcDeps = deps, fcExtra = extra }

119 here = FlatComponent { fcDeps = deps, fcExtra = extra }

111− goCond (cond, tree1, mtree2)

120+ goCond (cond, tree1, mtree2) = do

121+ b <- checkCond checkCond' cond

122+ if b

112− | checkCond cond = flattenComponent tree1

123+ then flattenComponent checkCond' tree1

113− | otherwise = maybe mempty flattenComponent mtree2

124+ else maybe (return mempty) (flattenComponent checkCond') mtree2

114

125

115−checkCond :: Condition ConfVar -> Bool

126+checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool

116−checkCond _ = False -- FIXME

127+checkCond CheckCond {..} cond0 =

128+ go cond0

129+ where

130+ go (Var (OS os)) = return $ os == ccOS

131+ go (Var (Arch arch)) = return $ arch == ccArch

132+ go (Var (Flag flag)) =

133+ case lookup flag ccFlags of

134+ Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0

135+ Just b -> return b

136+ go (Var (Impl flavor range)) = return

137+ $ flavor == ccCompilerFlavor

138+ && ccCompilerVersion `withinRange` range

139+ go (Lit b) = return b

140+ go (CNot c) = not `liftM` go c

141+ go (CAnd x y) = (&&) `liftM` go x `ap` go y

142+ go (COr x y) = (||) `liftM` go x `ap` go y

143+

144+data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar)

145+ deriving (Show, Typeable)

146+instance Exception CheckCondException

147+

148+data CheckCond = CheckCond

149+ { ccPackageName :: PackageName -- for debugging only

150+ , ccOS :: OS

151+ , ccArch :: Arch

152+ , ccFlags :: Map FlagName Bool

153+ , ccCompilerFlavor :: CompilerFlavor

154+ , ccCompilerVersion :: Version

155+ }