git.iko.soy/stackage
on master help sign in
Less global state
commitff2dd380b1a3ddc3cd00c6bd4ff8fa3e9c2f56c3 authorMichael Snoyman <michael@snoyman.com> dateSun 7 Dec 2014, 18:11 (12 years ago) parentad0cb8d
5 files changed+119−103
compare with master
unifiedsplit
Stackage2/BuildPlan.hs+31−61 Stackage2/CorePackages.hs+7 Stackage2/PackageConstraints.hs+79−39 Stackage2/PackageDescription.hs−1 test/Stackage2/BuildPlanSpec.hs+2−2
Stackage2/BuildPlan.hs+31−61
@@ -18,7 +18,6 @@ module Stackage2.BuildPlan
1818import Distribution.Package (Dependency (..))
1919import Distribution.PackageDescription
2020import Distribution.Version (withinRange, intersectVersionRanges)
21−import Stackage2.CorePackages
2221import Stackage2.PackageConstraints
2322import Stackage2.PackageIndex
2423import Stackage2.Prelude
@@ -122,44 +121,23 @@ instance desc ~ () => FromJSON (PackageBuild desc) where
122121
123122 efail = either (fail . show) return
124123
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)
147−newBuildPlan = liftIO $ do
148− core <- getCorePackages
149− coreExes <- getCoreExecutables
150− extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild
124+newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent)
125+newBuildPlan pc = liftIO $ do
126+ extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc)
151127 let toolMap = makeToolMap extraOrig
152− extra = populateUsers $ removeUnincluded toolMap coreExes extraOrig
128+ extra = populateUsers $ removeUnincluded pc toolMap extraOrig
153129 toolNames :: [ExeName]
154130 toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra
155131 tools <- topologicalSortTools toolMap $ mapFromList $ do
156132 exeName <- toolNames
157− guard $ exeName `notMember` coreExes
133+ guard $ exeName `notMember` pcCoreExecutables pc
158134 packageName <- maybe mempty setToList $ lookup exeName toolMap
159135 packageBuild <- maybeToList $ lookup packageName extraOrig
160136 return (packageName, packageBuild)
137+ -- FIXME topologically sort packages? maybe just leave that to the build phase
161138 return BuildPlan
162− { bpCore = core
139+ { bpCore = pcCorePackages pc
140+ -- bpCoreExes = pcCoreExecutables pc
163141 , bpTools = tools
164142 , bpExtra = extra
165143 }
@@ -206,16 +184,18 @@ data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
206184 deriving (Show, Typeable)
207185instance (Show key, Typeable key) => Exception (TopologicalSortException key)
208186
209−removeUnincluded :: Map ExeName (Set PackageName)
210− -> Set ExeName -- ^ core exes
187+removeUnincluded :: PackageConstraints
188+ -> Map ExeName (Set PackageName)
211189 -> Map PackageName (PackageBuild FlatComponent)
212190 -> Map PackageName (PackageBuild FlatComponent)
213−removeUnincluded toolMap coreExes orig =
191+removeUnincluded pc toolMap orig =
214192 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
215193 where
194+ coreExes = pcCoreExecutables pc
195+
216196 included :: Set PackageName
217197 included = flip execState mempty $
218− mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
198+ mapM_ (add . fst) $ mapToList $ pcPackages pc
219199
220200 add name = do
221201 inc <- get
@@ -240,56 +220,46 @@ populateUsers orig =
240220 | dep `member` fcDeps (pbDesc pb) = singletonSet user
241221 | otherwise = mempty
242222
243−isAllowed :: Map PackageName Version -- ^ core
223+isAllowed :: PackageConstraints
244224 -> PackageName -> Version -> Bool
245−isAllowed core = \name version ->
246− case lookup name core of
225+isAllowed pc = \name version ->
226+ case lookup name $ pcCorePackages pc of
247227 Just _ -> False -- never reinstall a core package
248228 Nothing ->
249− case lookup name $ pcPackages defaultPackageConstraints of
229+ case lookup name $ pcPackages pc of
250230 Nothing -> True -- no constraints
251231 Just (range, _) -> withinRange version range
252232
253233mkPackageBuild :: MonadThrow m
254− => GenericPackageDescription
234+ => PackageConstraints
235+ -> GenericPackageDescription
255236 -> m (PackageBuild FlatComponent)
256−mkPackageBuild gpd = do
257− let overrides = packageFlags name ++ defaultGlobalFlags
237+mkPackageBuild pc gpd = do
238+ let overrides = pcFlagOverrides pc name
258239 getFlag MkFlag {..} =
259240 (flagName, fromMaybe flagDefault $ lookup flagName overrides)
260241 flags = mapFromList $ map getFlag $ genPackageFlags gpd
261242 desc <- getFlattenedComponent
262243 CheckCond
263244 { ccPackageName = name
264− , ccOS = Distribution.System.Linux
265− , ccArch = Distribution.System.X86_64
245+ , ccOS = pcOS pc
246+ , ccArch = pcArch pc
266247 , ccCompilerFlavor = Distribution.Compiler.GHC
267− , ccCompilerVersion = ghcVerCabal
248+ , ccCompilerVersion = pcGhcVersion pc
268249 , ccFlags = flags
269250 }
270− (tryBuildTest name)
271− (tryBuildBenchmark name)
251+ (pcTests pc name /= Don'tBuild)
252+ (pcBuildBenchmark pc name)
272253 gpd
273254 return PackageBuild
274255 { pbVersion = version
275− , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints
256+ , pbMaintainer = fmap snd $ lookup name $ pcPackages pc
276257 , pbGithubPings = getGithubPings gpd
277258 , pbUsers = mempty -- must be filled in later
278259 , pbFlags = flags
279− , pbTestState =
280− case () of
281− ()
282− | not $ tryBuildTest name -> Don'tBuild
283− | name `member` pcExpectedFailures defaultPackageConstraints
284− -> ExpectFailure
285− | otherwise -> ExpectSuccess
286− , pbHaddockState =
287− case () of
288− ()
289− | name `member` pcExpectedFailures defaultPackageConstraints
290− -> ExpectFailure
291− | otherwise -> ExpectSuccess
292− , pbTryBuildBenchmark = tryBuildBenchmark name
260+ , pbTestState = pcTests pc name
261+ , pbHaddockState = pcHaddocks pc name
262+ , pbTryBuildBenchmark = pcBuildBenchmark pc name
293263 , pbDesc = desc
294264 }
295265 where
Stackage2/CorePackages.hs+7
@@ -3,6 +3,7 @@
33module Stackage2.CorePackages
44 ( getCorePackages
55 , getCoreExecutables
6+ , getGhcVersion
67 ) where
78
89import qualified Data.Text as T
@@ -44,3 +45,9 @@ getCoreExecutables = do
4445 Nothing -> error "No ghc executable found on PATH"
4546 Just fp -> return $ directory $ fpFromString fp
4647 (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 @@
44-- | The constraints on package selection for a new build plan.
55module Stackage2.PackageConstraints
66 ( PackageConstraints (..)
7+ , TestState (..)
78 , defaultPackageConstraints
8− , defaultGlobalFlags
9− , packageFlags
10− , tryBuildTest
11− , tryBuildBenchmark
12− , ghcVerCabal
139 ) where
1410
1511import Stackage2.Prelude
12+import Stackage2.CorePackages
1613import qualified Stackage.Config as Old
1714import qualified Stackage.Types as Old
1815import qualified Stackage.Select as Old
16+import Data.Aeson (ToJSON (..), FromJSON (..), withText)
17+import Distribution.System (OS, Arch)
18+import qualified Distribution.System
1919
20−-- FIXME have the defaults here live in IO to make sure we don't have any
21−-- global state floating around. Will make it easier to test.
20+data TestState = ExpectSuccess
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]
2240
2341data PackageConstraints = PackageConstraints
2442 { pcPackages :: Map PackageName (VersionRange, Maintainer)
2543 -- ^ This does not include core packages or dependencies, just packages
2644 -- added by some maintainer.
27− , pcExpectedFailures :: Set PackageName
28− -- ^ At some point in the future, we should split this into Haddock
29− -- failures, test failures, etc.
45+ , pcGhcVersion :: Version
46+ , pcOS :: OS
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
3054 }
3155
3256-- | The proposed plan from the requirements provided by contributors.
33−defaultPackageConstraints :: PackageConstraints
34−defaultPackageConstraints = PackageConstraints
35− { pcPackages = fmap (Maintainer . pack . Old.unMaintainer)
36− <$> Old.defaultStablePackages ghcVer False
37− , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False
38− }
39−
40−-- FIXME below here shouldn't be so hard-coded
57+defaultPackageConstraints :: IO PackageConstraints
58+defaultPackageConstraints = do
59+ core <- getCorePackages
60+ coreExes <- getCoreExecutables
61+ ghcVer <- getGhcVersion
62+ oldGhcVer <-
63+ case ghcVer of
64+ Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y
65+ _ -> error $ "Didn't not understand GHC version: " ++ show ghcVer
4166
42−ghcVer :: Old.GhcMajorVersion
43−ghcVer = Old.GhcMajorVersion 7 8
4467
45−ghcVerCabal :: Version
46−ghcVerCabal = Version [7, 8, 3] []
68+ let oldSettings = Old.defaultSelectSettings oldGhcVer False
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
4779
48−oldSettings :: Old.SelectSettings
49−oldSettings = Old.defaultSelectSettings ghcVer False
50−
51−defaultGlobalFlags :: Map FlagName Bool
52−defaultGlobalFlags = mapFromList $
53− map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
54− map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
80+ return PackageConstraints
81+ { pcPackages = fmap (Maintainer . pack . Old.unMaintainer)
82+ <$> Old.defaultStablePackages oldGhcVer False
83+ , pcCorePackages = core
84+ , pcCoreExecutables = coreExes
85+ , pcOS = Distribution.System.Linux -- FIXME don't hard-code?
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+ }
55103
56104packageFlags :: PackageName -> Map FlagName Bool
57105packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False
58106packageFlags _ = mempty
59107
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
67−skippedTests = (old ++ ) $ setFromList $ words =<<
108+extraSkippedTests :: HashSet Text
109+extraSkippedTests = setFromList $ words =<<
68110 [ "HTTP Octree options"
69111 , "hasql"
70112 , "bloodhound fb" -- require old hspec
71113 , "diagrams-haddock" -- requires old tasty
72114 , "hasql-postgres" -- requires old hasql
73115 ]
74− where
75− old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings
76116
77117skippedBenchs :: HashSet Text
78118skippedBenchs = setFromList $ words =<<
Stackage2/PackageDescription.hs−1
@@ -18,7 +18,6 @@ module Stackage2.PackageDescription
1818import Distribution.Package (Dependency (..))
1919import Distribution.PackageDescription
2020import Stackage2.CorePackages
21−import Stackage2.PackageConstraints
2221import Stackage2.PackageIndex
2322import Stackage2.Prelude
2423import Stackage2.GithubPings
test/Stackage2/BuildPlanSpec.hs+2−2
@@ -3,14 +3,14 @@ module Stackage2.BuildPlanSpec (spec) where
33
44import Stackage2.BuildPlan
55import Stackage2.Prelude
6+import Stackage2.PackageConstraints
67import Test.Hspec
78import qualified Data.Yaml as Y
89import Control.Exception (evaluate)
910
1011spec :: Spec
1112spec = it "works" $ do
12− bp <- newBuildPlan
13+ bp <- defaultPackageConstraints >>= newBuildPlan
1314 let bs = Y.encode bp
1415 mbp' = Y.decode bs
15− Y.encodeFile "myplan.yaml" bp
1616 mbp' `shouldBe` Just (() <$ bp)