git.iko.soy/stackage
on master help sign in
WIP changes with better naming
commit85597597bbc8a07315931ff095f4bac9e5e9cfd8 authorMichael Snoyman <michael@snoyman.com> dateMon 8 Dec 2014, 11:27 (12 years ago) parent3ccc779
9 files changed+326−300
compare with master
unifiedsplit
Stackage2/BuildConstraints.hs+186 Stackage2/BuildPlan.hs+69−130 Stackage2/CheckBuildPlan.hs+11−10 Stackage2/PackageConstraints.hs−123 Stackage2/PackageDescription.hs+7−4 Stackage2/Prelude.hs+17−3 Stackage2/UpdateBuildPlan.hs+22−17 stackage.cabal+1−1 test/Stackage2/BuildPlanSpec.hs+13−12
Stackage2/BuildConstraints.hsnew file+186
@@ -0,0 +1,186 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE TupleSections #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+-- | The constraints on package selection for a new build plan.
6+module Stackage2.BuildConstraints
7+ ( BuildConstraints (..)
8+ , PackageConstraints (..)
9+ , TestState (..)
10+ , SystemInfo (..)
11+ , defaultBuildConstraints
12+ ) where
13+
14+import Stackage2.Prelude
15+import Stackage2.CorePackages
16+import qualified Stackage.Config as Old
17+import qualified Stackage.Types as Old
18+import qualified Stackage.Select as Old
19+import Data.Aeson
20+import Distribution.System (OS, Arch)
21+import Distribution.Version (anyVersion)
22+import qualified Distribution.System
23+import qualified Data.Map as Map
24+
25+data TestState = ExpectSuccess
26+ | ExpectFailure
27+ | Don'tBuild -- ^ when the test suite will pull in things we don't want
28+ deriving (Show, Eq, Ord, Bounded, Enum)
29+
30+testStateToText :: TestState -> Text
31+testStateToText ExpectSuccess = "expect-success"
32+testStateToText ExpectFailure = "expect-failure"
33+testStateToText Don'tBuild = "do-not-build"
34+
35+instance ToJSON TestState where
36+ toJSON = toJSON . testStateToText
37+instance FromJSON TestState where
38+ parseJSON = withText "TestState" $ \t ->
39+ case lookup t states of
40+ Nothing -> fail $ "Invalid state: " ++ unpack t
41+ Just v -> return v
42+ where
43+ states = asHashMap $ mapFromList
44+ $ map (\x -> (testStateToText x, x)) [minBound..maxBound]
45+
46+data SystemInfo = SystemInfo
47+ { siGhcVersion :: Version
48+ , siOS :: OS
49+ , siArch :: Arch
50+ , siCorePackages :: Map PackageName Version
51+ , siCoreExecutables :: Set ExeName
52+ }
53+ deriving (Show, Eq, Ord)
54+instance ToJSON SystemInfo where
55+ toJSON SystemInfo {..} = object
56+ [ "ghc-version" .= display siGhcVersion
57+ , "os" .= display siOS
58+ , "arch" .= display siArch
59+ , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages)
60+ , "core-executables" .= siCoreExecutables
61+ ]
62+instance FromJSON SystemInfo where
63+ parseJSON = withObject "SystemInfo" $ \o -> do
64+ let helper name = (o .: name) >>= either (fail . show) return . simpleParse
65+ siGhcVersion <- helper "ghc-version"
66+ siOS <- helper "os"
67+ siArch <- helper "arch"
68+ siCorePackages <- (o .: "core-packages") >>= goPackages
69+ siCoreExecutables <- o .: "core-executables"
70+ return SystemInfo {..}
71+ where
72+ goPackages = either (fail . show) return
73+ . mapM simpleParse
74+ . Map.mapKeysWith const mkPackageName
75+
76+data BuildConstraints = BuildConstraints
77+ { bcPackages :: Set PackageName
78+ -- ^ This does not include core packages.
79+ , bcPackageConstraints :: PackageName -> PackageConstraints
80+
81+ , bcSystemInfo :: SystemInfo
82+ }
83+
84+data PackageConstraints = PackageConstraints
85+ { pcVersionRange :: VersionRange
86+ , pcMaintainer :: Maybe Maintainer
87+ , pcTests :: TestState
88+ , pcHaddocks :: TestState
89+ , pcBuildBenchmarks :: Bool
90+ , pcFlagOverrides :: Map FlagName Bool
91+ }
92+ deriving (Show, Eq)
93+instance ToJSON PackageConstraints where
94+ toJSON PackageConstraints {..} = object $ addMaintainer
95+ [ "version-range" .= display pcVersionRange
96+ , "tests" .= pcTests
97+ , "haddocks" .= pcHaddocks
98+ , "build-benchmarks" .= pcBuildBenchmarks
99+ , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides
100+ ]
101+ where
102+ addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer
103+instance FromJSON PackageConstraints where
104+ parseJSON = withObject "PackageConstraints" $ \o -> do
105+ pcVersionRange <- (o .: "version-range")
106+ >>= either (fail . show) return . simpleParse
107+ pcTests <- o .: "tests"
108+ pcHaddocks <- o .: "haddocks"
109+ pcBuildBenchmarks <- o .: "build-benchmarks"
110+ pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags"
111+ pcMaintainer <- o .:? "maintainer"
112+ return PackageConstraints {..}
113+
114+-- | The proposed plan from the requirements provided by contributors.
115+defaultBuildConstraints :: IO BuildConstraints
116+defaultBuildConstraints = do
117+ siCorePackages <- getCorePackages
118+ siCoreExecutables <- getCoreExecutables
119+ siGhcVersion <- getGhcVersion
120+ oldGhcVer <-
121+ case siGhcVersion of
122+ Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y
123+ _ -> error $ "Didn't not understand GHC version: " ++ show siGhcVersion
124+
125+
126+ let oldSettings = Old.defaultSelectSettings oldGhcVer False
127+ oldStable = Old.defaultStablePackages oldGhcVer False
128+ defaultGlobalFlags = asMap $ mapFromList $
129+ map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
130+ map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
131+ tryBuildTest (PackageName name) = pack name `notMember` skippedTests
132+ tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs
133+ expectedFailures = Old.defaultExpectedFailures oldGhcVer False
134+ skippedTests =
135+ old ++ extraSkippedTests
136+ where
137+ old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings
138+
139+ bcPackages = Map.keysSet oldStable
140+ bcPackageConstraints name =
141+ PackageConstraints {..}
142+ where
143+ mold = lookup name $ oldStable
144+
145+ pcVersionRange = simplifyVersionRange $ maybe anyVersion fst mold
146+ pcMaintainer = (Maintainer . pack . Old.unMaintainer . snd) <$> mold
147+ pcTests
148+ | not $ tryBuildTest name = Don'tBuild
149+ | name `member` expectedFailures = ExpectFailure
150+ | otherwise = ExpectSuccess
151+
152+ pcBuildBenchmarks = unPackageName name `notMember` skippedBenchs
153+
154+ -- FIXME ultimately separate haddock and test failures in specification
155+ pcHaddocks
156+ | name `member` expectedFailures = ExpectFailure
157+ | otherwise = ExpectSuccess
158+
159+ pcFlagOverrides = packageFlags name ++ defaultGlobalFlags
160+
161+ -- FIXME consider not hard-coding the next two values
162+ siOS = Distribution.System.Linux
163+ siArch = Distribution.System.X86_64
164+
165+ bcSystemInfo = SystemInfo {..}
166+
167+ return BuildConstraints {..}
168+
169+packageFlags :: PackageName -> Map FlagName Bool
170+packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False
171+packageFlags _ = mempty
172+
173+extraSkippedTests :: HashSet Text
174+extraSkippedTests = setFromList $ words =<<
175+ [ "HTTP Octree options"
176+ , "hasql"
177+ , "bloodhound fb" -- require old hspec
178+ , "diagrams-haddock" -- requires old tasty
179+ , "hasql-postgres" -- requires old hasql
180+ ]
181+
182+skippedBenchs :: HashSet Text
183+skippedBenchs = setFromList $ words =<<
184+ [ "machines criterion-plus graphviz lifted-base pandoc stm-containers uuid"
185+ , "cases hasql-postgres" -- pulls in criterion-plus, which has restrictive upper bounds
186+ ]
Stackage2/BuildPlan.hs+69−130
@@ -18,7 +18,7 @@ module Stackage2.BuildPlan
1818import Distribution.Package (Dependency (..))
1919import Distribution.PackageDescription
2020import Distribution.Version (withinRange, anyVersion, simplifyVersionRange)
21−import Stackage2.PackageConstraints
21+import Stackage2.BuildConstraints
2222import Stackage2.PackageIndex
2323import Stackage2.Prelude
2424import Stackage2.GithubPings
@@ -31,13 +31,9 @@ import qualified Distribution.System
3131import qualified Distribution.Compiler
3232
3333data BuildPlan desc = BuildPlan
34− { bpCore :: Map PackageName Version
35− , bpCoreExecutables :: Set ExeName
36− , bpGhcVersion :: Version
37− , bpOS :: Distribution.System.OS
38− , bpArch :: Distribution.System.Arch
34+ { bpSystemInfo :: SystemInfo
3935 , bpTools :: Vector (PackageName, Version)
40− , bpExtra :: Map PackageName (PackageBuild desc)
36+ , bpPackages :: Map PackageName (PackageBuild desc)
4137 }
4238 deriving (Functor, Foldable, Traversable, Show, Eq)
4339type instance Element (BuildPlan desc) = desc
@@ -47,58 +43,33 @@ instance MonoTraversable (BuildPlan desc)
4743
4844instance ToJSON (BuildPlan desc) where
4945 toJSON BuildPlan {..} = object
50− [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)
51− , "core-exes" .= bpCoreExecutables
52− , "ghc-version" .= asText (display bpGhcVersion)
53− , "os" .= asText (display bpOS)
54− , "arch" .= asText (display bpArch)
46+ [ "system-info" .= bpSystemInfo
5547 , "tools" .= map goTool bpTools
56− , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra
48+ , "packages" .= Map.mapKeysWith const unPackageName bpPackages
5749 ]
5850 where
59− toCore (x, y) = (asText $ display x, asText $ display y)
60− goTool (name, version) = object
61− [ "name" .= asText (display name)
62− , "version" .= asText (display version)
51+ goTool (k, v) = object
52+ [ "name" .= display k
53+ , "version" .= display v
6354 ]
6455instance desc ~ () => FromJSON (BuildPlan desc) where
6556 parseJSON = withObject "BuildPlan" $ \o -> do
66− bpCore <- (o .: "core") >>= goCore
67− bpCoreExecutables <- o .: "core-exes"
68− bpGhcVersion <- (o .: "ghc-version") >>= either (fail . show) return . simpleParse . asText
69− bpOS <- o .: "os" >>= either (fail . show) return . simpleParse . asText
70− bpArch <- (o .: "arch") >>= either (fail . show) return . simpleParse . asText
57+ bpSystemInfo <- o .: "system-info"
7158 bpTools <- (o .: "tools") >>= mapM goTool
72− bpExtra <- goExtra <$> (o .: "extra")
59+ bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")
7360 return BuildPlan {..}
7461 where
75− goCore =
76− fmap mapFromList . mapM goCore' . mapToList . asHashMap
77− where
78− goCore' (k, v) = do
79− k' <- either (fail . show) return $ simpleParse $ asText k
80− v' <- either (fail . show) return $ simpleParse $ asText v
81− return (k', v')
82−
8362 goTool = withObject "Tool" $ \o -> (,)
8463 <$> ((o .: "name") >>=
8564 either (fail . show) return . simpleParse . asText)
8665 <*> ((o .: "version") >>=
8766 either (fail . show) return . simpleParse . asText)
8867
89− goExtra = Map.mapKeysWith const PackageName
90−
9168data PackageBuild desc = PackageBuild
9269 { pbVersion :: Version
93− , pbVersionRange :: VersionRange
94− -- ^ This is vital for ensuring old constraints are kept in place when bumping
95− , pbMaintainer :: Maybe Maintainer
9670 , pbGithubPings :: Set Text
9771 , pbUsers :: Set PackageName
98− , pbFlags :: Map FlagName Bool
99− , pbTestState :: TestState
100− , pbHaddockState :: TestState
101− , pbTryBuildBenchmark :: Bool
72+ , pbPackageConstraints :: PackageConstraints
10273 , pbDesc :: desc
10374 }
10475 deriving (Functor, Foldable, Traversable, Show, Eq)
@@ -107,69 +78,45 @@ instance MonoFunctor (PackageBuild desc)
10778instance MonoFoldable (PackageBuild desc)
10879instance MonoTraversable (PackageBuild desc)
10980
110−-- | There seems to be a bug in Cabal where serializing and deserializing
111−-- version ranges winds up with different representations. So we have a
112−-- super-simplifier to deal with that.
113−superSimplifyVersionRange :: VersionRange -> VersionRange
114−superSimplifyVersionRange vr =
115− fromMaybe (assert False vr') $ simpleParse $ asList $ display vr'
116− where
117− vr' = simplifyVersionRange vr
118−
11981instance ToJSON (PackageBuild desc) where
120− toJSON PackageBuild {..} = object $ concat
121− [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
122− ,
123− [ "version" .= asText (display pbVersion)
124− , "version-range" .= asText (display $ superSimplifyVersionRange pbVersionRange)
125− , "github-pings" .= pbGithubPings
126− , "users" .= map unPackageName (unpack pbUsers)
127− , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags
128− , "test-state" .= pbTestState
129− , "haddock-state" .= pbHaddockState
130− , "build-benchmark" .= pbTryBuildBenchmark
131− ]
82+ toJSON PackageBuild {..} = object
83+ [ "version" .= asText (display pbVersion)
84+ , "github-pings" .= pbGithubPings
85+ , "users" .= map unPackageName (unpack pbUsers)
86+ , "constraints" .= pbPackageConstraints
13287 ]
13388instance desc ~ () => FromJSON (PackageBuild desc) where
134− parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
135− <$> (o .: "version" >>= efail . simpleParse . asText)
136− <*> (o .: "version-range" >>= fmap superSimplifyVersionRange . efail . simpleParse . asText)
137− <*> o .:? "maintainer"
138− <*> o .:? "github-pings" .!= mempty
139− <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
140− <*> (toFlags <$> (o .:? "flags" .!= mempty))
141− <*> o .: "test-state"
142− <*> o .: "haddock-state"
143− <*> o .: "build-benchmark"
144− <*> pure ()
89+ parseJSON = withObject "PackageBuild" $ \o -> do
90+ pbVersion <- o .: "version" >>= efail . simpleParse . asText
91+ pbGithubPings <- o .:? "github-pings" .!= mempty
92+ pbUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)
93+ pbPackageConstraints <- o .: "constraints"
94+ return PackageBuild {..}
14595 where
146− toFlags = Map.mapKeysWith const (FlagName . unpack . asText)
147−
96+ pbDesc = ()
14897 efail = either (fail . show) return
14998
150−newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent)
151−newBuildPlan pc = liftIO $ do
152− extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc)
99+newBuildPlan :: MonadIO m => BuildConstraints -> m (BuildPlan FlatComponent)
100+newBuildPlan bc@BuildConstraints {..} = liftIO $ do
101+ extraOrig <- getLatestDescriptions (isAllowed bc) (mkPackageBuild bc)
153102 let toolMap = makeToolMap extraOrig
154− extra = populateUsers $ removeUnincluded pc toolMap extraOrig
103+ extra = populateUsers $ removeUnincluded bc toolMap extraOrig
155104 toolNames :: [ExeName]
156105 toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra
157106 tools <- topologicalSortTools toolMap $ mapFromList $ do
158107 exeName <- toolNames
159− guard $ exeName `notMember` pcCoreExecutables pc
108+ guard $ exeName `notMember` siCoreExecutables
160109 packageName <- maybe mempty setToList $ lookup exeName toolMap
161110 packageBuild <- maybeToList $ lookup packageName extraOrig
162111 return (packageName, packageBuild)
163112 -- FIXME topologically sort packages? maybe just leave that to the build phase
164113 return BuildPlan
165− { bpCore = pcCorePackages pc
166− , bpCoreExecutables = pcCoreExecutables pc
167− , bpGhcVersion = pcGhcVersion pc
168− , bpOS = pcOS pc
169− , bpArch = pcArch pc
114+ { bpSystemInfo = bcSystemInfo
170115 , bpTools = tools
171− , bpExtra = extra
116+ , bpPackages = extra
172117 }
118+ where
119+ SystemInfo {..} = bcSystemInfo
173120
174121makeToolMap :: Map PackageName (PackageBuild FlatComponent)
175122 -> Map ExeName (Set PackageName)
@@ -213,18 +160,19 @@ data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
213160 deriving (Show, Typeable)
214161instance (Show key, Typeable key) => Exception (TopologicalSortException key)
215162
216−removeUnincluded :: PackageConstraints
163+-- | Include only packages which are dependencies of the required packages and
164+-- their build tools.
165+removeUnincluded :: BuildConstraints
217166 -> Map ExeName (Set PackageName)
218167 -> Map PackageName (PackageBuild FlatComponent)
219168 -> Map PackageName (PackageBuild FlatComponent)
220−removeUnincluded pc toolMap orig =
169+removeUnincluded BuildConstraints {..} toolMap orig =
221170 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
222171 where
223− coreExes = pcCoreExecutables pc
172+ SystemInfo {..} = bcSystemInfo
224173
225174 included :: Set PackageName
226− included = flip execState mempty $
227− mapM_ (add . fst) $ mapToList $ pcPackages pc
175+ included = flip execState mempty $ mapM_ add bcPackages
228176
229177 add name = do
230178 inc <- get
@@ -235,7 +183,7 @@ removeUnincluded pc toolMap orig =
235183 Just pb -> do
236184 mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
237185 forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $
238− \exeName -> when (exeName `notMember` coreExes)
186+ \exeName -> when (exeName `notMember` siCoreExecutables)
239187 $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap
240188
241189populateUsers :: Map PackageName (PackageBuild FlatComponent)
@@ -249,49 +197,40 @@ populateUsers orig =
249197 | dep `member` fcDeps (pbDesc pb) = singletonSet user
250198 | otherwise = mempty
251199
252−isAllowed :: PackageConstraints
200+-- | Check whether the given package/version combo meets the constraints
201+-- currently in place.
202+isAllowed :: BuildConstraints
253203 -> PackageName -> Version -> Bool
254−isAllowed pc = \name version ->
255− case lookup name $ pcCorePackages pc of
204+isAllowed bc = \name version ->
205+ case lookup name $ siCorePackages $ bcSystemInfo bc of
256206 Just _ -> False -- never reinstall a core package
257− Nothing ->
258− case lookup name $ pcPackages pc of
259− Nothing -> True -- no constraints
260− Just (range, _) -> withinRange version range
207+ Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name
261208
262209mkPackageBuild :: MonadThrow m
263− => PackageConstraints
210+ => BuildConstraints
264211 -> GenericPackageDescription
265212 -> m (PackageBuild FlatComponent)
266−mkPackageBuild pc gpd = do
267− let overrides = pcFlagOverrides pc name
268− getFlag MkFlag {..} =
269− (flagName, fromMaybe flagDefault $ lookup flagName overrides)
270− flags = mapFromList $ map getFlag $ genPackageFlags gpd
271− desc <- getFlattenedComponent
272− CheckCond
273− { ccPackageName = name
274− , ccOS = pcOS pc
275− , ccArch = pcArch pc
276− , ccCompilerFlavor = Distribution.Compiler.GHC
277− , ccCompilerVersion = pcGhcVersion pc
278− , ccFlags = flags
279− }
280− (pcTests pc name /= Don'tBuild)
281− (pcBuildBenchmark pc name)
282− gpd
283− return PackageBuild
284− { pbVersion = version
285− , pbVersionRange = superSimplifyVersionRange
286− $ maybe anyVersion fst $ lookup name $ pcPackages pc
287− , pbMaintainer = lookup name (pcPackages pc) >>= snd
288− , pbGithubPings = getGithubPings gpd
289− , pbUsers = mempty -- must be filled in later
290− , pbFlags = flags
291− , pbTestState = pcTests pc name
292− , pbHaddockState = pcHaddocks pc name
293− , pbTryBuildBenchmark = pcBuildBenchmark pc name
294− , pbDesc = desc
295− }
213+mkPackageBuild bc gpd = do
214+ pbDesc <- getFlattenedComponent CheckCond {..} gpd
215+ return PackageBuild {..}
296216 where
297− PackageIdentifier name version = package $ packageDescription gpd
217+ PackageIdentifier name pbVersion = package $ packageDescription gpd
218+ pbGithubPings = getGithubPings gpd
219+ pbPackageConstraints = bcPackageConstraints bc name
220+ pbUsers = mempty -- must be filled in later
221+
222+ ccPackageName = name
223+ ccOS = siOS
224+ ccArch = siArch
225+ ccCompilerFlavor = Distribution.Compiler.GHC
226+ ccCompilerVersion = siGhcVersion
227+ ccFlags = flags
228+ ccIncludeTests = pcTests pbPackageConstraints /= Don'tBuild
229+ ccIncludeBenchmarks = pcBuildBenchmarks pbPackageConstraints
230+
231+ SystemInfo {..} = bcSystemInfo bc
232+
233+ overrides = pcFlagOverrides pbPackageConstraints
234+ getFlag MkFlag {..} =
235+ (flagName, fromMaybe flagDefault $ lookup flagName overrides)
236+ flags = mapFromList $ map getFlag $ genPackageFlags gpd
Stackage2/CheckBuildPlan.hs+11−10
@@ -10,6 +10,7 @@ module Stackage2.CheckBuildPlan
1010
1111import Stackage2.Prelude
1212import Stackage2.BuildPlan
13+import Stackage2.BuildConstraints
1314import Stackage2.PackageDescription
1415import Control.Monad.Writer.Strict (execWriter, Writer, tell)
1516
@@ -18,9 +19,9 @@ checkBuildPlan BuildPlan {..}
1819 | null errs' = return ()
1920 | otherwise = throwM errs
2021 where
21− allPackages = bpCore ++ map pbVersion bpExtra
22+ allPackages = siCorePackages bpSystemInfo ++ map pbVersion bpPackages
2223 errs@(BadBuildPlan errs') =
23− execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra
24+ execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
2425
2526checkDeps :: Map PackageName Version
2627 -> (PackageName, PackageBuild FlatComponent)
@@ -41,7 +42,7 @@ checkDeps allPackages (user, pb) =
4142 pu = PkgUser
4243 { puName = user
4344 , puVersion = pbVersion pb
44− , puMaintainer = pbMaintainer pb
45+ , puMaintainer = pcMaintainer $ pbPackageConstraints pb
4546 , puGithubPings = pbGithubPings pb
4647 }
4748
@@ -53,17 +54,17 @@ data PkgUser = PkgUser
5354 }
5455 deriving (Eq, Ord)
5556
56−pkgUserShow1 :: PkgUser -> String
57+pkgUserShow1 :: PkgUser -> Text
5758pkgUserShow1 PkgUser {..} = concat
5859 [ display puName
5960 , "-"
6061 , display puVersion
6162 ]
6263
63−pkgUserShow2 :: PkgUser -> String
64+pkgUserShow2 :: PkgUser -> Text
6465pkgUserShow2 PkgUser {..} = unwords
65− $ (maybe "No maintainer" (unpack . unMaintainer) puMaintainer ++ ".")
66− : map (("@" ++) . unpack) (setToList puGithubPings)
66+ $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
67+ : map (cons '@') (setToList puGithubPings)
6768
6869newtype BadBuildPlan =
6970 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
@@ -71,13 +72,13 @@ newtype BadBuildPlan =
7172instance Exception BadBuildPlan
7273instance Show BadBuildPlan where
7374 show (BadBuildPlan errs) =
74− concatMap go $ mapToList errs
75+ unpack $ concatMap go $ mapToList errs
7576 where
7677 go ((dep, mdepVer), users) = unlines
7778 $ showDepVer dep mdepVer
7879 : map showUser (mapToList users)
7980
80− showDepVer :: PackageName -> Maybe Version -> String
81+ showDepVer :: PackageName -> Maybe Version -> Text
8182 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
8283 showDepVer dep (Just version) = concat
8384 [ display dep
@@ -86,7 +87,7 @@ instance Show BadBuildPlan where
8687 , " depended on by:"
8788 ]
8889
89− showUser :: (PkgUser, VersionRange) -> String
90+ showUser :: (PkgUser, VersionRange) -> Text
9091 showUser (pu, range) = concat
9192 [ "- "
9293 , pkgUserShow1 pu
Stackage2/PackageConstraints.hsdeleted−123
@@ -1,123 +0,0 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−{-# LANGUAGE TupleSections #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−-- | The constraints on package selection for a new build plan.
5−module Stackage2.PackageConstraints
6− ( PackageConstraints (..)
7− , TestState (..)
8− , defaultPackageConstraints
9− ) where
10−
11−import Stackage2.Prelude
12−import Stackage2.CorePackages
13−import qualified Stackage.Config as Old
14−import qualified Stackage.Types as Old
15−import qualified Stackage.Select as Old
16−import Data.Aeson (ToJSON (..), FromJSON (..), withText)
17−import Distribution.System (OS, Arch)
18−import qualified Distribution.System
19−
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]
40−
41−data PackageConstraints = PackageConstraints
42− { pcPackages :: Map PackageName (VersionRange, Maybe Maintainer)
43− -- ^ This does not include core packages or dependencies, just packages
44− -- added by some maintainer.
45− , pcGhcVersion :: Version
46− , pcOS :: OS
47− , pcArch :: Arch
48− , pcCorePackages :: Map PackageName Version
49− , pcCoreExecutables :: Set ExeName
50−
51− -- Have a single lookup function with all of the package-specific stuff?
52− , pcTests :: PackageName -> TestState
53− , pcHaddocks :: PackageName -> TestState
54− , pcBuildBenchmark :: PackageName -> Bool
55− , pcFlagOverrides :: PackageName -> Map FlagName Bool
56− }
57−
58−-- | The proposed plan from the requirements provided by contributors.
59−defaultPackageConstraints :: IO PackageConstraints
60−defaultPackageConstraints = do
61− core <- getCorePackages
62− coreExes <- getCoreExecutables
63− ghcVer <- getGhcVersion
64− oldGhcVer <-
65− case ghcVer of
66− Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y
67− _ -> error $ "Didn't not understand GHC version: " ++ show ghcVer
68−
69−
70− let oldSettings = Old.defaultSelectSettings oldGhcVer False
71− defaultGlobalFlags = asMap $ mapFromList $
72− map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
73− map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
74− tryBuildTest (PackageName name) = pack name `notMember` skippedTests
75− tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs
76− expectedFailures = Old.defaultExpectedFailures oldGhcVer False
77− skippedTests =
78− old ++ extraSkippedTests
79− where
80− old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings
81−
82− return PackageConstraints
83− { pcPackages = fmap (Just . Maintainer . pack . Old.unMaintainer)
84− <$> Old.defaultStablePackages oldGhcVer False
85− , pcCorePackages = core
86− , pcCoreExecutables = coreExes
87− , pcOS = Distribution.System.Linux -- FIXME don't hard-code?
88− , pcArch = Distribution.System.X86_64
89− , pcGhcVersion = ghcVer
90− , pcTests = \name ->
91− case () of
92− ()
93− | not $ tryBuildTest name -> Don'tBuild
94− | name `member` expectedFailures -> ExpectFailure
95− | otherwise -> ExpectSuccess
96− , pcBuildBenchmark = (`notMember` skippedBenchs) . unPackageName
97− , pcFlagOverrides = \name -> packageFlags name ++ defaultGlobalFlags
98− , pcHaddocks = \name ->
99− case () of
100− ()
101− | name `member` expectedFailures
102− -> ExpectFailure
103− | otherwise -> ExpectSuccess
104− }
105−
106−packageFlags :: PackageName -> Map FlagName Bool
107−packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False
108−packageFlags _ = mempty
109−
110−extraSkippedTests :: HashSet Text
111−extraSkippedTests = setFromList $ words =<<
112− [ "HTTP Octree options"
113− , "hasql"
114− , "bloodhound fb" -- require old hspec
115− , "diagrams-haddock" -- requires old tasty
116− , "hasql-postgres" -- requires old hasql
117− ]
118−
119−skippedBenchs :: HashSet Text
120−skippedBenchs = setFromList $ words =<<
121− [ "machines criterion-plus graphviz lifted-base pandoc stm-containers uuid"
122− , "cases hasql-postgres" -- pulls in criterion-plus, which has restrictive upper bounds
123− ]
Stackage2/PackageDescription.hs+7−4
@@ -55,14 +55,15 @@ instance Monoid SimpleExtra where
5555getFlattenedComponent
5656 :: MonadThrow m
5757 => CheckCond
58− -> Bool -- ^ include test suites?
59− -> Bool -- ^ include benchmarks?
6058 -> GenericPackageDescription
6159 -> m FlatComponent
62−getFlattenedComponent checkCond' includeTests includeBench gpd =
60+getFlattenedComponent checkCond' gpd =
6361 liftM fold
6462 $ mapM (flattenComponent checkCond')
65− $ getSimpleTrees includeTests includeBench gpd
63+ $ getSimpleTrees
64+ (ccIncludeTests checkCond')
65+ (ccIncludeBenchmarks checkCond')
66+ gpd
6667
6768getSimpleTrees :: Bool -- ^ include test suites?
6869 -> Bool -- ^ include benchmarks?
@@ -150,4 +151,6 @@ data CheckCond = CheckCond
150151 , ccFlags :: Map FlagName Bool
151152 , ccCompilerFlavor :: CompilerFlavor
152153 , ccCompilerVersion :: Version
154+ , ccIncludeTests :: Bool
155+ , ccIncludeBenchmarks :: Bool
153156 }
Stackage2/Prelude.hs+17−3
@@ -24,14 +24,19 @@ import Distribution.Version as X (withinRange)
2424unPackageName :: PackageName -> Text
2525unPackageName (PackageName str) = pack str
2626
27+unFlagName :: FlagName -> Text
28+unFlagName (FlagName str) = pack str
29+
2730mkPackageName :: Text -> PackageName
2831mkPackageName = PackageName . unpack
2932
30−display :: (IsString text, Element text ~ Char, DT.Text a) => a -> text
33+mkFlagName :: Text -> FlagName
34+mkFlagName = FlagName . unpack
35+
36+display :: DT.Text a => a -> Text
3137display = fromString . DT.display
3238
33−simpleParse :: (MonadThrow m, DT.Text a, Typeable a, MonoFoldable text, Element text ~ Char)
34− => text -> m a
39+simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a
3540simpleParse orig = withTypeRep $ \rep ->
3641 case DT.simpleParse str of
3742 Nothing -> throwM (ParseFailedException rep (pack str))
@@ -87,3 +92,12 @@ newtype ExeName = ExeName { unExeName :: Text }
8792
8893intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange
8994intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y
95+
96+-- | There seems to be a bug in Cabal where serializing and deserializing
97+-- version ranges winds up with different representations. So we have a
98+-- super-simplifier to deal with that.
99+simplifyVersionRange :: VersionRange -> VersionRange
100+simplifyVersionRange vr =
101+ fromMaybe (assert False vr') $ simpleParse $ display vr'
102+ where
103+ vr' = C.simplifyVersionRange vr
Stackage2/UpdateBuildPlan.hs+22−17
@@ -4,36 +4,41 @@
44-- | Take an existing build plan and bump all packages to the newest version in
55-- the same major version number.
66module Stackage2.UpdateBuildPlan
7− ( updatePackageConstraints
7+ ( updateBuildConstraints
88 , updateBuildPlan
99 ) where
1010
1111import Stackage2.Prelude
1212import Stackage2.BuildPlan
13−import Stackage2.PackageConstraints
13+import Stackage2.BuildConstraints
1414import Stackage2.PackageDescription
1515import Distribution.Version (orLaterVersion, earlierVersion)
16+import qualified Data.Map as Map
1617
1718updateBuildPlan :: BuildPlan a -> IO (BuildPlan FlatComponent)
18−updateBuildPlan = newBuildPlan . updatePackageConstraints
19+updateBuildPlan = newBuildPlan . updateBuildConstraints
1920
20−updatePackageConstraints :: BuildPlan a -> PackageConstraints
21−updatePackageConstraints BuildPlan {..} = PackageConstraints
22− { pcPackages = flip map bpExtra $ \pb ->
21+updateBuildConstraints :: BuildPlan a -> BuildConstraints
22+updateBuildConstraints BuildPlan {..} =
23+ BuildConstraints {..}
24+ where
25+ bcSystemInfo = bpSystemInfo
26+ bcPackages = Map.keysSet bpPackages
27+
28+ bcPackageConstraints name =
29+ PackageConstraints {..}
30+ where
31+ {-
32+ pcPackages = flip map bpExtra $ \pb ->
2333 ( intersectVersionRanges (bumpRange (pbVersion pb)) (pbVersionRange pb)
2434 , pbMaintainer pb
2535 )
26− , pcCorePackages = bpCore
27− , pcCoreExecutables = bpCoreExecutables
28− , pcGhcVersion = bpGhcVersion
29− , pcOS = bpOS
30− , pcArch = bpArch
31− , pcTests = maybe ExpectSuccess pbTestState . flip lookup bpExtra
32− , pcHaddocks = maybe ExpectSuccess pbHaddockState . flip lookup bpExtra
33− , pcBuildBenchmark = maybe True pbTryBuildBenchmark . flip lookup bpExtra
34− , pcFlagOverrides = maybe mempty pbFlags . flip lookup bpExtra
35− }
36− where
36+ pcTests = maybe ExpectSuccess pbTestState . flip lookup bpExtra
37+ pcHaddocks = maybe ExpectSuccess pbHaddockState . flip lookup bpExtra
38+ pcBuildBenchmark = maybe True pbTryBuildBenchmark . flip lookup bpExtra
39+ pcFlagOverrides = maybe mempty pbFlags . flip lookup bpExtra
40+ -}
41+
3742 bumpRange version = intersectVersionRanges
3843 (orLaterVersion version)
3944 (earlierVersion $ bumpVersion version)
stackage.cabal+1−1
@@ -32,7 +32,7 @@ library
3232 Stackage.ServerFiles
3333
3434 Stackage2.Prelude
35− Stackage2.PackageConstraints
35+ Stackage2.BuildConstraints
3636 Stackage2.CorePackages
3737 Stackage2.PackageIndex
3838 Stackage2.BuildPlan
test/Stackage2/BuildPlanSpec.hs+13−12
@@ -3,7 +3,7 @@ module Stackage2.BuildPlanSpec (spec) where
33
44import Stackage2.BuildPlan
55import Stackage2.Prelude
6−import Stackage2.PackageConstraints
6+import Stackage2.BuildConstraints
77import Stackage2.UpdateBuildPlan
88import Test.Hspec
99import qualified Data.Yaml as Y
@@ -13,23 +13,24 @@ import qualified Data.Map as Map
1313
1414spec :: Spec
1515spec = it "works" $ do
16− pc <- defaultPackageConstraints
17− bp <- newBuildPlan pc
16+ bc <- defaultBuildConstraints
17+ bp <- newBuildPlan bc
1818 let bs = Y.encode bp
19− mbp' = Y.decode bs
19+ ebp' = Y.decodeEither bs
2020
21− bp' <- maybe (error "decoding failed") return mbp'
21+ bp' <- either error return ebp'
2222
23− let allPackages = Map.keysSet (bpExtra bp) ++ Map.keysSet (bpExtra bp')
23+ let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp')
2424 forM_ allPackages $ \name ->
25− (name, lookup name (bpExtra bp')) `shouldBe`
26− (name, lookup name (bpExtra $ () <$ bp))
25+ (name, lookup name (bpPackages bp')) `shouldBe`
26+ (name, lookup name (bpPackages (() <$ bp)))
2727
28− mbp' `shouldBe` Just (() <$ bp)
29− bp2 <- newBuildPlan $ updatePackageConstraints bp
28+ bp' `shouldBe` (() <$ bp)
29+ bp2 <- updateBuildPlan bp
3030 dropVersionRanges bp2 `shouldBe` dropVersionRanges bp
3131 where
3232 dropVersionRanges bp =
33− bp { bpExtra = map go $ bpExtra bp }
33+ bp { bpPackages = map go $ bpPackages bp }
3434 where
35− go pb = pb { pbVersionRange = anyVersion }
35+ go pb = pb { pbPackageConstraints = go' $ pbPackageConstraints pb }
36+ go' pc = pc { pcVersionRange = anyVersion }