@@ -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