git.iko.soy/stackage
on master help sign in
Horribly messy BuildPlan
bf47dedMichael Snoyman
Stackage2/BuildPlan.hsnew file+302
compare with master
unifiedsplit
@@ -0,0 +1,302 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE DeriveFunctor #-}
5+{-# LANGUAGE DeriveFoldable #-}
6+{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE TypeFamilies #-}
8+-- | Representation of a concrete build plan, and how to generate a new one
9+-- based on constraints.
10+module Stackage2.BuildPlan
11+ ( BuildPlan (..)
12+ , PackageBuild (..)
13+ , newBuildPlan
14+ ) where
15+
16+import Distribution.Package (Dependency (..))
17+import Distribution.PackageDescription
18+import Distribution.Version (withinRange, intersectVersionRanges)
19+import Stackage2.CorePackages
20+import Stackage2.PackageConstraints
21+import Stackage2.PackageIndex
22+import Stackage2.Prelude
23+import Control.Monad.State.Strict (execState, get, put)
24+import qualified Data.Map as Map
25+import qualified Data.Set as Set
26+import Data.Aeson
27+
28+data BuildPlan desc = BuildPlan
29+ { bpCore :: Map PackageName Version
30+ , bpTools :: Vector (PackageName, Version)
31+ , bpExtra :: Map PackageName (PackageBuild desc)
32+ , bpGlobalFlags :: Map FlagName Bool
33+ }
34+ deriving (Functor, Foldable, Traversable, Show, Eq)
35+type instance Element (BuildPlan desc) = desc
36+instance MonoFunctor (BuildPlan desc)
37+instance MonoFoldable (BuildPlan desc)
38+instance MonoTraversable (BuildPlan desc)
39+
40+instance ToJSON (BuildPlan desc) where
41+ toJSON BuildPlan {..} = object
42+ [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)
43+ , "tools" .= map goTool bpTools
44+ , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra
45+ , "global-flags" .= Map.mapKeysWith const (\(FlagName f) -> f) bpGlobalFlags
46+ ]
47+ where
48+ toCore (x, y) = (asText $ display x, asText $ display y)
49+ goTool (name, version) = object
50+ [ "name" .= asText (display name)
51+ , "version" .= asText (display version)
52+ ]
53+instance desc ~ () => FromJSON (BuildPlan desc) where
54+ parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
55+ <$> ((o .: "core") >>= goCore)
56+ <*> ((o .: "tools") >>= mapM goTool)
57+ <*> (goExtra <$> (o .: "extra"))
58+ <*> (goFlags <$> (o .: "global-flags"))
59+ where
60+ goCore =
61+ fmap mapFromList . mapM goCore' . mapToList . asHashMap
62+ where
63+ goCore' (k, v) = do
64+ k' <- either (fail . show) return $ simpleParse $ asText k
65+ v' <- either (fail . show) return $ simpleParse $ asText v
66+ return (k', v')
67+
68+ goTool = withObject "Tool" $ \o -> (,)
69+ <$> ((o .: "name") >>=
70+ either (fail . show) return . simpleParse . asText)
71+ <*> ((o .: "version") >>=
72+ either (fail . show) return . simpleParse . asText)
73+
74+ goExtra = Map.mapKeysWith const PackageName
75+ goFlags = Map.mapKeysWith const FlagName
76+
77+data PackageBuild desc = PackageBuild
78+ { pbVersion :: Version
79+ , pbMaintainer :: Maybe Maintainer
80+ , pbUsers :: Set PackageName
81+ , pbFlags :: Map FlagName Bool
82+ , pbTestState :: TestState
83+ , pbHaddockState :: TestState
84+ , pbTryBuildBenchmark :: Bool
85+ , pbDesc :: desc
86+ }
87+ deriving (Functor, Foldable, Traversable, Show, Eq)
88+type instance Element (PackageBuild desc) = desc
89+instance MonoFunctor (PackageBuild desc)
90+instance MonoFoldable (PackageBuild desc)
91+instance MonoTraversable (PackageBuild desc)
92+
93+instance ToJSON (PackageBuild desc) where
94+ toJSON PackageBuild {..} = object $ concat
95+ [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
96+ ,
97+ [ "version" .= asText (display pbVersion)
98+ , "users" .= map unPackageName (unpack pbUsers)
99+ , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags
100+ , "test-state" .= pbTestState
101+ , "haddock-state" .= pbHaddockState
102+ , "build-benchmark" .= pbTryBuildBenchmark
103+ ]
104+ ]
105+instance desc ~ () => FromJSON (PackageBuild desc) where
106+ parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
107+ <$> (o .: "version" >>= efail . simpleParse . asText)
108+ <*> o .:? "maintainer"
109+ <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
110+ <*> (toFlags <$> (o .:? "flags" .!= mempty))
111+ <*> o .: "test-state"
112+ <*> o .: "haddock-state"
113+ <*> o .: "build-benchmark"
114+ <*> pure ()
115+ where
116+ toFlags = Map.mapKeysWith const (FlagName . unpack . asText)
117+
118+ efail = either (fail . show) return
119+
120+data TestState = ExpectSuccess
121+ | ExpectFailure
122+ | Don'tBuild -- ^ when the test suite will pull in things we don't want
123+ deriving (Show, Eq, Ord, Bounded, Enum)
124+
125+testStateToText :: TestState -> Text
126+testStateToText ExpectSuccess = "expect-success"
127+testStateToText ExpectFailure = "expect-failure"
128+testStateToText Don'tBuild = "do-not-build"
129+
130+instance ToJSON TestState where
131+ toJSON = toJSON . testStateToText
132+instance FromJSON TestState where
133+ parseJSON = withText "TestState" $ \t ->
134+ case lookup t states of
135+ Nothing -> fail $ "Invalid state: " ++ unpack t
136+ Just v -> return v
137+ where
138+ states = asHashMap $ mapFromList
139+ $ map (\x -> (testStateToText x, x)) [minBound..maxBound]
140+
141+newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)
142+newBuildPlan = liftIO $ do
143+ core <- getCorePackages
144+ extraOrig <- getLatestDescriptions (isAllowed core) simplifyDesc
145+ let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig
146+ extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig
147+ return BuildPlan
148+ { bpCore = core
149+ , bpTools = topologicalSort
150+ $ filter (\(x, _) -> x `member` toolNames)
151+ $ mapToList extra
152+ , bpExtra = extra
153+ , bpGlobalFlags = defaultGlobalFlags
154+ }
155+
156+topologicalSort :: [(PackageName, PackageBuild FlatComponent)]
157+ -> Vector (PackageName, Version)
158+topologicalSort = fromList . fmap (fmap pbVersion) -- FIXME
159+
160+removeUnincluded :: Set PackageName -- ^ tool names
161+ -> Map PackageName (PackageBuild FlatComponent)
162+ -> Map PackageName (PackageBuild FlatComponent)
163+removeUnincluded toolNames orig =
164+ mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
165+ where
166+ included :: Set PackageName
167+ included = flip execState mempty $ do
168+ mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
169+ mapM_ add toolNames
170+
171+ add name = do
172+ inc <- get
173+ when (name `notMember` inc) $ do
174+ put $ insertSet name inc
175+ case lookup name orig of
176+ Nothing -> return ()
177+ Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
178+
179+populateUsers :: Map PackageName (PackageBuild FlatComponent)
180+ -> Map PackageName (PackageBuild FlatComponent)
181+populateUsers orig =
182+ mapWithKey go orig
183+ where
184+ go name pb = pb { pbUsers = foldMap (go2 name) (mapToList orig) }
185+
186+ go2 dep (user, pb)
187+ | dep `member` fcDeps (pbDesc pb) = singletonSet user
188+ | otherwise = mempty
189+
190+data SimpleTree = SimpleTree
191+ { stDeps :: Map PackageName VersionRange
192+ , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]
193+ , stExtra :: SimpleExtra
194+ }
195+ deriving Show
196+instance Monoid SimpleTree where
197+ mempty = SimpleTree mempty mempty mempty
198+ mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree
199+ (unionWith intersectVersionRanges a x)
200+ (b ++ y)
201+ (c ++ z)
202+
203+data SimpleExtra = SimpleExtra
204+ { seTools :: Map PackageName VersionRange
205+ }
206+ deriving Show
207+instance Monoid SimpleExtra where
208+ mempty = SimpleExtra mempty
209+ mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra
210+ (unionWith intersectVersionRanges a x)
211+
212+getSimpleTrees :: Bool -- ^ include test suites?
213+ -> Bool -- ^ include benchmarks?
214+ -> GenericPackageDescription
215+ -> [SimpleTree]
216+getSimpleTrees includeTests includeBench gpd = concat
217+ [ maybe [] (return . go libBuildInfo) $ condLibrary gpd
218+ , map (go buildInfo . snd) $ condExecutables gpd
219+ , if includeTests
220+ then map (go testBuildInfo . snd) $ condTestSuites gpd
221+ else []
222+ , if includeBench
223+ then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd
224+ else []
225+ ]
226+ where
227+ go getExtra (CondNode dat deps comps) = SimpleTree
228+ { stDeps = unionsWith intersectVersionRanges
229+ $ map (\(Dependency x y) -> singletonMap x y) deps
230+ , stConds = map (goComp getExtra) comps
231+ , stExtra = toSimpleExtra $ getExtra dat
232+ }
233+
234+ goComp getExtra (cond, tree1, mtree2) =
235+ (cond, go getExtra tree1, go getExtra <$> mtree2)
236+
237+ toSimpleExtra bi = SimpleExtra
238+ { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)
239+ $ \(Dependency name range) -> singletonMap name range
240+ }
241+
242+data FlatComponent = FlatComponent
243+ { fcDeps :: Map PackageName VersionRange
244+ , fcExtra :: SimpleExtra
245+ }
246+ deriving Show
247+instance Monoid FlatComponent where
248+ mempty = FlatComponent mempty mempty
249+ mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent
250+ (unionWith intersectVersionRanges a x)
251+ (b ++ y)
252+
253+flattenComponent :: SimpleTree -> FlatComponent
254+flattenComponent (SimpleTree deps conds extra) =
255+ mconcat $ here : map goCond conds
256+ where
257+ here = FlatComponent { fcDeps = deps, fcExtra = extra }
258+ goCond (cond, tree1, mtree2)
259+ | checkCond cond = flattenComponent tree1
260+ | otherwise = maybe mempty flattenComponent mtree2
261+
262+checkCond :: Condition ConfVar -> Bool
263+checkCond _ = False -- FIXME
264+
265+simplifyDesc :: GenericPackageDescription -> IO (PackageBuild FlatComponent)
266+simplifyDesc gpd = do
267+ return PackageBuild
268+ { pbVersion = version
269+ , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints
270+ , pbUsers = mempty -- must be filled in later
271+ , pbFlags = packageFlags name
272+ , pbTestState =
273+ case () of
274+ ()
275+ | not $ tryBuildTest name -> Don'tBuild
276+ | name `member` pcExpectedFailures defaultPackageConstraints
277+ -> ExpectFailure
278+ | otherwise -> ExpectSuccess
279+ , pbHaddockState =
280+ case () of
281+ ()
282+ | name `member` pcExpectedFailures defaultPackageConstraints
283+ -> ExpectFailure
284+ | otherwise -> ExpectSuccess
285+ , pbTryBuildBenchmark = tryBuildBenchmark name
286+ , pbDesc = foldMap flattenComponent $ getSimpleTrees
287+ (tryBuildTest name)
288+ (tryBuildBenchmark name)
289+ gpd
290+ }
291+ where
292+ PackageIdentifier name version = package $ packageDescription gpd
293+
294+isAllowed :: Map PackageName Version -- ^ core
295+ -> PackageName -> Version -> Bool
296+isAllowed core = \name version ->
297+ case lookup name core of
298+ Just _ -> False -- never reinstall a core package
299+ Nothing ->
300+ case lookup name $ pcPackages defaultPackageConstraints of
301+ Nothing -> True -- no constraints
302+ Just (range, _) -> withinRange version range
Stackage2/PackageConstraints.hs+29−2
@@ -1,14 +1,23 @@
1{-# LANGUAGE NoImplicitPrelude #-}
1{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
3-- | The constraints on package selection for a new build plan.
4-- | The constraints on package selection for a new build plan.
4module Stackage2.PackageConstraints
5module Stackage2.PackageConstraints
5 ( PackageConstraints (..)
6 ( PackageConstraints (..)
6 , defaultPackageConstraints
7 , defaultPackageConstraints
8+ , defaultGlobalFlags
9+ , packageFlags
10+ , tryBuildTest
11+ , tryBuildBenchmark
7 ) where
12 ) where
8
13
9import Stackage2.Prelude
14import Stackage2.Prelude
10import qualified Stackage.Config as Old
15import qualified Stackage.Config as Old
11import qualified Stackage.Types as Old
16import qualified Stackage.Types as Old
17+import qualified Stackage.Select as Old
18+
19+-- FIXME have the defaults here live in IO to make sure we don't have any
20+-- global state floating around. Will make it easier to test.
12
21
13data PackageConstraints = PackageConstraints
22data PackageConstraints = PackageConstraints
14 { pcPackages :: Map PackageName (VersionRange, Maintainer)
23 { pcPackages :: Map PackageName (VersionRange, Maintainer)
@@ -26,5 +35,23 @@ defaultPackageConstraints = PackageConstraints
26 <$> Old.defaultStablePackages ghcVer False
35 <$> Old.defaultStablePackages ghcVer False
27 , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False
36 , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False
28 }
37 }
29− where
38+
39+ghcVer :: Old.GhcMajorVersion
30− ghcVer = Old.GhcMajorVersion 7 8
40+ghcVer = Old.GhcMajorVersion 7 8
41+
42+oldSettings :: Old.SelectSettings
43+oldSettings = Old.defaultSelectSettings ghcVer False
44+
45+defaultGlobalFlags :: Map FlagName Bool
46+defaultGlobalFlags = mapFromList $
47+ map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
48+ map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
49+
50+packageFlags :: PackageName -> Map FlagName Bool
51+packageFlags _ = mempty
52+
53+tryBuildTest :: PackageName -> Bool
54+tryBuildTest = (`member` Old.skippedTests oldSettings)
55+
56+tryBuildBenchmark :: PackageName -> Bool
57+tryBuildBenchmark _ = True
Stackage2/PackageIndex.hs+4−5
@@ -112,12 +112,11 @@ instance Exception CabalParseException
112-- given criterion.
112-- given criterion.
113getLatestDescriptions :: MonadIO m
113getLatestDescriptions :: MonadIO m
114 => (PackageName -> Version -> Bool)
114 => (PackageName -> Version -> Bool)
115+ -> (GenericPackageDescription -> IO desc)
115− -> m (Map PackageName (Version, GenericPackageDescription))
116+ -> m (Map PackageName desc)
116−getLatestDescriptions f = liftIO $ do
117+getLatestDescriptions f parseDesc = liftIO $ do
117 m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty
118 m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty
118− forM m $ \ucf -> do
119− gpd <- ucfParse ucf
119+ forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc
120− return (ucfVersion ucf, gpd)
121 where
120 where
122 f' ucf = f (ucfName ucf) (ucfVersion ucf)
121 f' ucf = f (ucfName ucf) (ucfVersion ucf)
123 add m ucf =
122 add m ucf =
Stackage2/Prelude.hs+4
@@ -2,6 +2,7 @@
2{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5module Stackage2.Prelude
6module Stackage2.Prelude
6 ( module X
7 ( module X
7 , module Stackage2.Prelude
8 , module Stackage2.Prelude
@@ -12,9 +13,11 @@ import Data.Conduit.Process as X
12import Data.Typeable (TypeRep, typeOf)
13import Data.Typeable (TypeRep, typeOf)
13import Distribution.Package as X (PackageIdentifier (..),
14import Distribution.Package as X (PackageIdentifier (..),
14 PackageName (PackageName))
15 PackageName (PackageName))
16+import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription)
15import qualified Distribution.Text as DT
17import qualified Distribution.Text as DT
16import Distribution.Version as X (Version (..), VersionRange)
18import Distribution.Version as X (Version (..), VersionRange)
17import System.Exit (ExitCode (ExitSuccess))
19import System.Exit (ExitCode (ExitSuccess))
20+import Data.Aeson (ToJSON, FromJSON)
18
21
19unPackageName :: PackageName -> Text
22unPackageName :: PackageName -> Text
20unPackageName (PackageName str) = pack str
23unPackageName (PackageName str) = pack str
@@ -74,3 +77,4 @@ withCheckedProcess cp f = do
74 return res
77 return res
75
78
76newtype Maintainer = Maintainer { unMaintainer :: Text }
79newtype Maintainer = Maintainer { unMaintainer :: Text }
80+ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)
stackage.cabal+6
@@ -35,6 +35,7 @@ library
35 Stackage2.PackageConstraints
35 Stackage2.PackageConstraints
36 Stackage2.CorePackages
36 Stackage2.CorePackages
37 Stackage2.PackageIndex
37 Stackage2.PackageIndex
38+ Stackage2.BuildPlan
38 build-depends: base >= 4 && < 5
39 build-depends: base >= 4 && < 5
39 , containers
40 , containers
40 , Cabal >= 1.14
41 , Cabal >= 1.14
@@ -53,6 +54,8 @@ library
53 , classy-prelude-conduit
54 , classy-prelude-conduit
54 , text
55 , text
55 , system-fileio
56 , system-fileio
57+ , mtl
58+ , aeson
56
59
57executable stackage
60executable stackage
58 default-language: Haskell2010
61 default-language: Haskell2010
@@ -69,12 +72,15 @@ test-suite spec
69 main-is: Spec.hs
72 main-is: Spec.hs
70 other-modules: Stackage2.CorePackagesSpec
73 other-modules: Stackage2.CorePackagesSpec
71 Stackage2.PackageIndexSpec
74 Stackage2.PackageIndexSpec
75+ Stackage2.BuildPlanSpec
72 build-depends: base
76 build-depends: base
73 , stackage
77 , stackage
74 , hspec
78 , hspec
75 , QuickCheck
79 , QuickCheck
76 , text
80 , text
77 , classy-prelude-conduit
81 , classy-prelude-conduit
82+ , Cabal
83+ , yaml
78
84
79source-repository head
85source-repository head
80 type: git
86 type: git
test/Stackage2/BuildPlanSpec.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
2+module Stackage2.BuildPlanSpec (spec) where
3+
4+import Stackage2.BuildPlan
5+import Stackage2.Prelude
6+import Test.Hspec
7+import qualified Data.Yaml as Y
8+import Control.Exception (evaluate)
9+
10+spec :: Spec
11+spec = it "works" $ do
12+ bp <- newBuildPlan
13+ let bs = Y.encode bp
14+ mbp' = Y.decode bs
15+ mbp' `shouldBe` Just (() <$ bp)
test/Stackage2/PackageIndexSpec.hs+3−2
@@ -4,6 +4,7 @@ module Stackage2.PackageIndexSpec (spec) where
4import Stackage2.PackageIndex
4import Stackage2.PackageIndex
5import Stackage2.Prelude
5import Stackage2.Prelude
6import Test.Hspec
6import Test.Hspec
7+import Distribution.Package (packageId, pkgVersion)
7
8
8spec :: Spec
9spec :: Spec
9spec = do
10spec = do
@@ -13,8 +14,8 @@ spec = do
13 [ (asText "base", asText "4.5.0.0")
14 [ (asText "base", asText "4.5.0.0")
14 , ("does-not-exist", "9999999999999999999")
15 , ("does-not-exist", "9999999999999999999")
15 ])
16 ])
16− m <- getLatestDescriptions f
17+ m <- getLatestDescriptions f return
17 length m `shouldBe` 1
18 length m `shouldBe` 1
18 p <- simpleParse $ asText "base"
19 p <- simpleParse $ asText "base"
19 v <- simpleParse $ asText "4.5.0.0"
20 v <- simpleParse $ asText "4.5.0.0"
20− (fst <$> m) `shouldBe` singletonMap p v
21+ (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v