ff2dd38 · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

Less global state

ff2dd38Michael Snoyman12 years ago

Stackage2/BuildPlan.hs+31−61

compare with master

unifiedsplit

@@ -18,7 +18,6 @@ module Stackage2.BuildPlan

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

19import Distribution.PackageDescription

20import Distribution.Version (withinRange, intersectVersionRanges)

21−import Stackage2.CorePackages

22import Stackage2.PackageConstraints

21import Stackage2.PackageConstraints

23import Stackage2.PackageIndex

22import Stackage2.PackageIndex

24import Stackage2.Prelude

23import Stackage2.Prelude

@@ -122,44 +121,23 @@ instance desc ~ () => FromJSON (PackageBuild desc) where

122

121

123 efail = either (fail . show) return

122 efail = either (fail . show) return

124

123

125−data TestState = ExpectSuccess

126− | ExpectFailure

127− | Don'tBuild -- ^ when the test suite will pull in things we don't want

128− deriving (Show, Eq, Ord, Bounded, Enum)

129−

130−testStateToText :: TestState -> Text

131−testStateToText ExpectSuccess = "expect-success"

132−testStateToText ExpectFailure = "expect-failure"

133−testStateToText Don'tBuild = "do-not-build"

134−

135−instance ToJSON TestState where

136− toJSON = toJSON . testStateToText

137−instance FromJSON TestState where

138− parseJSON = withText "TestState" $ \t ->

139− case lookup t states of

140− Nothing -> fail $ "Invalid state: " ++ unpack t

141− Just v -> return v

142− where

143− states = asHashMap $ mapFromList

144− $ map (\x -> (testStateToText x, x)) [minBound..maxBound]

145−

146−newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)

124+newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent)

147−newBuildPlan = liftIO $ do

125+newBuildPlan pc = liftIO $ do

148− core <- getCorePackages

149− coreExes <- getCoreExecutables

150− extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild

126+ extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc)

151 let toolMap = makeToolMap extraOrig

127 let toolMap = makeToolMap extraOrig

152− extra = populateUsers $ removeUnincluded toolMap coreExes extraOrig

128+ extra = populateUsers $ removeUnincluded pc toolMap extraOrig

153 toolNames :: [ExeName]

129 toolNames :: [ExeName]

154 toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra

130 toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra

155 tools <- topologicalSortTools toolMap $ mapFromList $ do

131 tools <- topologicalSortTools toolMap $ mapFromList $ do

156 exeName <- toolNames

132 exeName <- toolNames

157− guard $ exeName `notMember` coreExes

133+ guard $ exeName `notMember` pcCoreExecutables pc

158 packageName <- maybe mempty setToList $ lookup exeName toolMap

134 packageName <- maybe mempty setToList $ lookup exeName toolMap

159 packageBuild <- maybeToList $ lookup packageName extraOrig

135 packageBuild <- maybeToList $ lookup packageName extraOrig

160 return (packageName, packageBuild)

136 return (packageName, packageBuild)

137+ -- FIXME topologically sort packages? maybe just leave that to the build phase

161 return BuildPlan

138 return BuildPlan

162− { bpCore = core

139+ { bpCore = pcCorePackages pc

140+ -- bpCoreExes = pcCoreExecutables pc

163 , bpTools = tools

141 , bpTools = tools

164 , bpExtra = extra

142 , bpExtra = extra

165 }

143 }

@@ -206,16 +184,18 @@ data TopologicalSortException key = NoEmptyDeps (Map key (Set key))

206 deriving (Show, Typeable)

184 deriving (Show, Typeable)

207instance (Show key, Typeable key) => Exception (TopologicalSortException key)

185instance (Show key, Typeable key) => Exception (TopologicalSortException key)

208

186

187+removeUnincluded :: PackageConstraints

209−removeUnincluded :: Map ExeName (Set PackageName)

188+ -> Map ExeName (Set PackageName)

210− -> Set ExeName -- ^ core exes

211 -> Map PackageName (PackageBuild FlatComponent)

189 -> Map PackageName (PackageBuild FlatComponent)

212 -> Map PackageName (PackageBuild FlatComponent)

190 -> Map PackageName (PackageBuild FlatComponent)

213−removeUnincluded toolMap coreExes orig =

191+removeUnincluded pc toolMap orig =

214 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig

192 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig

215 where

193 where

194+ coreExes = pcCoreExecutables pc

195+

216 included :: Set PackageName

196 included :: Set PackageName

217 included = flip execState mempty $

197 included = flip execState mempty $

218− mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints

198+ mapM_ (add . fst) $ mapToList $ pcPackages pc

219

199

220 add name = do

200 add name = do

221 inc <- get

201 inc <- get

@@ -240,56 +220,46 @@ populateUsers orig =

240 | dep `member` fcDeps (pbDesc pb) = singletonSet user

220 | dep `member` fcDeps (pbDesc pb) = singletonSet user

241 | otherwise = mempty

221 | otherwise = mempty

242

222

243−isAllowed :: Map PackageName Version -- ^ core

223+isAllowed :: PackageConstraints

244 -> PackageName -> Version -> Bool

224 -> PackageName -> Version -> Bool

245−isAllowed core = \name version ->

225+isAllowed pc = \name version ->

246− case lookup name core of

226+ case lookup name $ pcCorePackages pc of

247 Just _ -> False -- never reinstall a core package

227 Just _ -> False -- never reinstall a core package

248 Nothing ->

228 Nothing ->

249− case lookup name $ pcPackages defaultPackageConstraints of

229+ case lookup name $ pcPackages pc of

250 Nothing -> True -- no constraints

230 Nothing -> True -- no constraints

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

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

252

232

253mkPackageBuild :: MonadThrow m

233mkPackageBuild :: MonadThrow m

234+ => PackageConstraints

254− => GenericPackageDescription

235+ -> GenericPackageDescription

255 -> m (PackageBuild FlatComponent)

236 -> m (PackageBuild FlatComponent)

256−mkPackageBuild gpd = do

237+mkPackageBuild pc gpd = do

257− let overrides = packageFlags name ++ defaultGlobalFlags

238+ let overrides = pcFlagOverrides pc name

258 getFlag MkFlag {..} =

239 getFlag MkFlag {..} =

259 (flagName, fromMaybe flagDefault $ lookup flagName overrides)

240 (flagName, fromMaybe flagDefault $ lookup flagName overrides)

260 flags = mapFromList $ map getFlag $ genPackageFlags gpd

241 flags = mapFromList $ map getFlag $ genPackageFlags gpd

261 desc <- getFlattenedComponent

242 desc <- getFlattenedComponent

262 CheckCond

243 CheckCond

263 { ccPackageName = name

244 { ccPackageName = name

264− , ccOS = Distribution.System.Linux

245+ , ccOS = pcOS pc

265− , ccArch = Distribution.System.X86_64

246+ , ccArch = pcArch pc

266 , ccCompilerFlavor = Distribution.Compiler.GHC

247 , ccCompilerFlavor = Distribution.Compiler.GHC

267− , ccCompilerVersion = ghcVerCabal

248+ , ccCompilerVersion = pcGhcVersion pc

268 , ccFlags = flags

249 , ccFlags = flags

269 }

250 }

270− (tryBuildTest name)

251+ (pcTests pc name /= Don'tBuild)

271− (tryBuildBenchmark name)

252+ (pcBuildBenchmark pc name)

272 gpd

253 gpd

273 return PackageBuild

254 return PackageBuild

274 { pbVersion = version

255 { pbVersion = version

275− , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints

256+ , pbMaintainer = fmap snd $ lookup name $ pcPackages pc

276 , pbGithubPings = getGithubPings gpd

257 , pbGithubPings = getGithubPings gpd

277 , pbUsers = mempty -- must be filled in later

258 , pbUsers = mempty -- must be filled in later

278 , pbFlags = flags

259 , pbFlags = flags

279− , pbTestState =

260+ , pbTestState = pcTests pc name

280− case () of

281− ()

282− | not $ tryBuildTest name -> Don'tBuild

283− | name `member` pcExpectedFailures defaultPackageConstraints

284− -> ExpectFailure

285− | otherwise -> ExpectSuccess

286− , pbHaddockState =

261+ , pbHaddockState = pcHaddocks pc name

287− case () of

288− ()

289− | name `member` pcExpectedFailures defaultPackageConstraints

290− -> ExpectFailure

291− | otherwise -> ExpectSuccess

292− , pbTryBuildBenchmark = tryBuildBenchmark name

262+ , pbTryBuildBenchmark = pcBuildBenchmark pc name

293 , pbDesc = desc

263 , pbDesc = desc

294 }

264 }

295 where

265 where

Stackage2/CorePackages.hs+7

@@ -3,6 +3,7 @@

3module Stackage2.CorePackages

4 ( getCorePackages

5 , getCoreExecutables

6+ , getGhcVersion

6 ) where

7 ) where

8import qualified Data.Text as T

9import qualified Data.Text as T

@@ -44,3 +45,9 @@ getCoreExecutables = do

44 Nothing -> error "No ghc executable found on PATH"

45 Nothing -> error "No ghc executable found on PATH"

45 Just fp -> return $ directory $ fpFromString fp

46 Just fp -> return $ directory $ fpFromString fp

46 (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir

47 (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir

48+

49+getGhcVersion :: IO Version

50+getGhcVersion = do

51+ withCheckedProcess (proc "ghc" ["--numeric-version"]) $

52+ \ClosedStream src Inherited ->

53+ (src $$ decodeUtf8C =$ foldC) >>= simpleParse

Stackage2/PackageConstraints.hs+79−39

@@ -4,75 +4,115 @@

4-- | The constraints on package selection for a new build plan.

5module Stackage2.PackageConstraints

6 ( PackageConstraints (..)

7+ , TestState (..)

7 , defaultPackageConstraints

8 , defaultPackageConstraints

8− , defaultGlobalFlags

9− , packageFlags

10− , tryBuildTest

11− , tryBuildBenchmark

12− , ghcVerCabal

13 ) where

9 ) where

15import Stackage2.Prelude

11import Stackage2.Prelude

12+import Stackage2.CorePackages

16import qualified Stackage.Config as Old

13import qualified Stackage.Config as Old

17import qualified Stackage.Types as Old

14import qualified Stackage.Types as Old

18import qualified Stackage.Select as Old

15import qualified Stackage.Select as Old

16+import Data.Aeson (ToJSON (..), FromJSON (..), withText)

17+import Distribution.System (OS, Arch)

18+import qualified Distribution.System

20−-- FIXME have the defaults here live in IO to make sure we don't have any

20+data TestState = ExpectSuccess

21−-- global state floating around. Will make it easier to test.

21+ | ExpectFailure

22+ | Don'tBuild -- ^ when the test suite will pull in things we don't want

23+ deriving (Show, Eq, Ord, Bounded, Enum)

24+

25+testStateToText :: TestState -> Text

26+testStateToText ExpectSuccess = "expect-success"

27+testStateToText ExpectFailure = "expect-failure"

28+testStateToText Don'tBuild = "do-not-build"

29+

30+instance ToJSON TestState where

31+ toJSON = toJSON . testStateToText

32+instance FromJSON TestState where

33+ parseJSON = withText "TestState" $ \t ->

34+ case lookup t states of

35+ Nothing -> fail $ "Invalid state: " ++ unpack t

36+ Just v -> return v

37+ where

38+ states = asHashMap $ mapFromList

39+ $ map (\x -> (testStateToText x, x)) [minBound..maxBound]

23data PackageConstraints = PackageConstraints

41data PackageConstraints = PackageConstraints

24 { pcPackages :: Map PackageName (VersionRange, Maintainer)

42 { pcPackages :: Map PackageName (VersionRange, Maintainer)

25 -- ^ This does not include core packages or dependencies, just packages

43 -- ^ This does not include core packages or dependencies, just packages

26 -- added by some maintainer.

44 -- added by some maintainer.

27− , pcExpectedFailures :: Set PackageName

45+ , pcGhcVersion :: Version

28− -- ^ At some point in the future, we should split this into Haddock

46+ , pcOS :: OS

29− -- failures, test failures, etc.

47+ , pcArch :: Arch

48+ , pcFlagOverrides :: PackageName -> Map FlagName Bool

49+ , pcTests :: PackageName -> TestState

50+ , pcHaddocks :: PackageName -> TestState

51+ , pcBuildBenchmark :: PackageName -> Bool

52+ , pcCorePackages :: Map PackageName Version

53+ , pcCoreExecutables :: Set ExeName

30 }

54 }

32-- | The proposed plan from the requirements provided by contributors.

56-- | The proposed plan from the requirements provided by contributors.

33−defaultPackageConstraints :: PackageConstraints

57+defaultPackageConstraints :: IO PackageConstraints

34−defaultPackageConstraints = PackageConstraints

58+defaultPackageConstraints = do

35− { pcPackages = fmap (Maintainer . pack . Old.unMaintainer)

59+ core <- getCorePackages

36− <$> Old.defaultStablePackages ghcVer False

60+ coreExes <- getCoreExecutables

37− , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False

61+ ghcVer <- getGhcVersion

38− }

62+ oldGhcVer <-

39−

63+ case ghcVer of

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

64+ Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y

65+ _ -> error $ "Didn't not understand GHC version: " ++ show ghcVer

42−ghcVer :: Old.GhcMajorVersion

43−ghcVer = Old.GhcMajorVersion 7 8

45−ghcVerCabal :: Version

68+ let oldSettings = Old.defaultSelectSettings oldGhcVer False

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

69+ defaultGlobalFlags = asMap $ mapFromList $

70+ map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++

71+ map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)

72+ tryBuildTest (PackageName name) = pack name `notMember` skippedTests

73+ tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs

74+ expectedFailures = Old.defaultExpectedFailures oldGhcVer False

75+ skippedTests =

76+ old ++ extraSkippedTests

77+ where

78+ old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings

48−oldSettings :: Old.SelectSettings

80+ return PackageConstraints

49−oldSettings = Old.defaultSelectSettings ghcVer False

81+ { pcPackages = fmap (Maintainer . pack . Old.unMaintainer)

50−

82+ <$> Old.defaultStablePackages oldGhcVer False

51−defaultGlobalFlags :: Map FlagName Bool

83+ , pcCorePackages = core

52−defaultGlobalFlags = mapFromList $

84+ , pcCoreExecutables = coreExes

53− map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++

85+ , pcOS = Distribution.System.Linux -- FIXME don't hard-code?

54− map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)

86+ , pcArch = Distribution.System.X86_64

87+ , pcGhcVersion = ghcVer

88+ , pcTests = \name ->

89+ case () of

90+ ()

91+ | not $ tryBuildTest name -> Don'tBuild

92+ | name `member` expectedFailures -> ExpectFailure

93+ | otherwise -> ExpectSuccess

94+ , pcBuildBenchmark = (`notMember` skippedBenchs) . unPackageName

95+ , pcFlagOverrides = \name -> packageFlags name ++ defaultGlobalFlags

96+ , pcHaddocks = \name ->

97+ case () of

98+ ()

99+ | name `member` expectedFailures

100+ -> ExpectFailure

101+ | otherwise -> ExpectSuccess

102+ }

103

56packageFlags :: PackageName -> Map FlagName Bool

104packageFlags :: PackageName -> Map FlagName Bool

57packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False

105packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False

58packageFlags _ = mempty

106packageFlags _ = mempty

107

60−tryBuildTest :: PackageName -> Bool

61−tryBuildTest (PackageName name) = pack name `notMember` skippedTests

62−

63−tryBuildBenchmark :: PackageName -> Bool

64−tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs

65−

66−skippedTests :: HashSet Text

108+extraSkippedTests :: HashSet Text

67−skippedTests = (old ++ ) $ setFromList $ words =<<

109+extraSkippedTests = setFromList $ words =<<

68 [ "HTTP Octree options"

110 [ "HTTP Octree options"

69 , "hasql"

111 , "hasql"

70 , "bloodhound fb" -- require old hspec

112 , "bloodhound fb" -- require old hspec

71 , "diagrams-haddock" -- requires old tasty

113 , "diagrams-haddock" -- requires old tasty

72 , "hasql-postgres" -- requires old hasql

114 , "hasql-postgres" -- requires old hasql

73 ]

115 ]

74− where

75− old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings

116

77skippedBenchs :: HashSet Text

117skippedBenchs :: HashSet Text

78skippedBenchs = setFromList $ words =<<

118skippedBenchs = setFromList $ words =<<

Stackage2/PackageDescription.hs−1

@@ -18,7 +18,6 @@ module Stackage2.PackageDescription

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

19import Distribution.PackageDescription

20import Stackage2.CorePackages

21−import Stackage2.PackageConstraints

22import Stackage2.PackageIndex

21import Stackage2.PackageIndex

23import Stackage2.Prelude

22import Stackage2.Prelude

24import Stackage2.GithubPings

23import Stackage2.GithubPings

test/Stackage2/BuildPlanSpec.hs+2−2

@@ -3,14 +3,14 @@ module Stackage2.BuildPlanSpec (spec) where

4import Stackage2.BuildPlan

5import Stackage2.Prelude

6+import Stackage2.PackageConstraints

6import Test.Hspec

7import Test.Hspec

7import qualified Data.Yaml as Y

8import qualified Data.Yaml as Y

8import Control.Exception (evaluate)

9import Control.Exception (evaluate)

10spec :: Spec

11spec :: Spec

11spec = it "works" $ do

12spec = it "works" $ do

12− bp <- newBuildPlan

13+ bp <- defaultPackageConstraints >>= newBuildPlan

13 let bs = Y.encode bp

14 let bs = Y.encode bp

14 mbp' = Y.decode bs

15 mbp' = Y.decode bs

15− Y.encodeFile "myplan.yaml" bp

16 mbp' `shouldBe` Just (() <$ bp)