git.iko.soy/stackage
on master help sign in
Correct discovery of build tools deps
31efd7eMichael Snoyman
Stackage2/BuildPlan.hs+62−14
compare with master
unifiedsplit
@@ -1,4 +1,6 @@
1{-# LANGUAGE NoImplicitPrelude #-}
1{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveFunctor #-}
@@ -146,32 +148,76 @@ instance FromJSON TestState where
146newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)
148newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)
147newBuildPlan = liftIO $ do
149newBuildPlan = liftIO $ do
148 core <- getCorePackages
150 core <- getCorePackages
151+ coreExes <- getCoreExecutables
149 extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild
152 extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild
153+ let toolMap = makeToolMap extraOrig
154+ extra = populateUsers $ removeUnincluded toolMap extraOrig
155+ toolNames :: [ExeName]
150− let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig -- FIXME extraOrig ==> extra
156+ toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra
151− extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig
157+ tools <- topologicalSortTools toolMap $ mapFromList $ do
158+ exeName <- toolNames
159+ guard $ exeName `notMember` coreExes
160+ packageName <- maybe mempty setToList $ lookup exeName toolMap
161+ packageBuild <- maybeToList $ lookup packageName extraOrig
162+ return (packageName, packageBuild)
152 return BuildPlan
163 return BuildPlan
153 { bpCore = core
164 { bpCore = core
154− , bpTools = topologicalSort
165+ , bpTools = tools
155− $ filter (\(x, _) -> x `member` toolNames)
156− $ mapToList extra
157 , bpExtra = extra
166 , bpExtra = extra
158 , bpGlobalFlags = defaultGlobalFlags
167 , bpGlobalFlags = defaultGlobalFlags
159 }
168 }
160
169
170+makeToolMap :: Map PackageName (PackageBuild FlatComponent)
171+ -> Map ExeName (Set PackageName)
172+makeToolMap =
173+ unionsWith (++) . map go . mapToList
174+ where
175+ go (packageName, pb) =
176+ foldMap go' $ seProvidedExes $ fcExtra $ pbDesc pb
177+ where
178+ go' exeName = singletonMap exeName (singletonSet packageName)
179+
180+topologicalSortTools :: MonadThrow m
181+ => Map ExeName (Set PackageName)
161−topologicalSort :: [(PackageName, PackageBuild FlatComponent)]
182+ -> Map PackageName (PackageBuild FlatComponent)
162− -> Vector (PackageName, Version)
183+ -> m (Vector (PackageName, Version))
163−topologicalSort = fromList . fmap (fmap pbVersion) -- FIXME
184+topologicalSortTools toolMap = topologicalSort
185+ pbVersion
186+ (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . seTools . fcExtra . pbDesc)
187+
188+topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key)
189+ => (value -> finalValue)
190+ -> (value -> Set key) -- ^ deps
191+ -> Map key value
192+ -> m (Vector (key, finalValue))
193+topologicalSort toFinal toDeps =
194+ loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal)
195+ where
196+ removeSelfDeps k (deps, final) = (deleteSet k deps, final)
197+ loop front toProcess | null toProcess = return $ pack $ front []
198+ loop front toProcess
199+ | null noDeps = throwM $ NoEmptyDeps (map fst toProcess')
200+ | otherwise = loop (front . noDeps') (mapFromList hasDeps)
201+ where
202+ toProcess' = fmap (first removeUnavailable) toProcess
203+ allKeys = Map.keysSet toProcess
204+ removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList
205+ (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess'
206+ noDeps' = (map (second snd) noDeps ++)
207+
208+data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
209+ deriving (Show, Typeable)
210+instance (Show key, Typeable key) => Exception (TopologicalSortException key)
164
211
165−removeUnincluded :: Set PackageName -- ^ tool names
212+removeUnincluded :: Map ExeName (Set PackageName)
166 -> Map PackageName (PackageBuild FlatComponent)
213 -> Map PackageName (PackageBuild FlatComponent)
167 -> Map PackageName (PackageBuild FlatComponent)
214 -> Map PackageName (PackageBuild FlatComponent)
168−removeUnincluded toolNames orig =
215+removeUnincluded toolMap orig =
169 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
216 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
170 where
217 where
171 included :: Set PackageName
218 included :: Set PackageName
172− included = flip execState mempty $ do
219+ included = flip execState mempty $
173 mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
220 mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
174− mapM_ add toolNames -- FIXME remove this
175
221
176 add name = do
222 add name = do
177 inc <- get
223 inc <- get
@@ -179,8 +225,10 @@ removeUnincluded toolNames orig =
179 put $ insertSet name inc
225 put $ insertSet name inc
180 case lookup name orig of
226 case lookup name orig of
181 Nothing -> return ()
227 Nothing -> return ()
228+ Just pb -> do
182− Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
229+ mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
183− -- FIXME add tools here
230+ forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $
231+ \exeName -> mapM_ add $ fromMaybe mempty $ lookup exeName toolMap
184
232
185populateUsers :: Map PackageName (PackageBuild FlatComponent)
233populateUsers :: Map PackageName (PackageBuild FlatComponent)
186 -> Map PackageName (PackageBuild FlatComponent)
234 -> Map PackageName (PackageBuild FlatComponent)
Stackage2/CorePackages.hs+13
@@ -2,10 +2,13 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Stackage2.CorePackages
3module Stackage2.CorePackages
4 ( getCorePackages
4 ( getCorePackages
5+ , getCoreExecutables
5 ) where
6 ) where
6
7
7import qualified Data.Text as T
8import qualified Data.Text as T
9+import Filesystem (listDirectory)
8import Stackage2.Prelude
10import Stackage2.Prelude
11+import System.Directory (findExecutable)
9
12
10-- | Get a @Map@ of all of the core packages. Core packages are defined as
13-- | Get a @Map@ of all of the core packages. Core packages are defined as
11-- packages which ship with GHC itself.
14-- packages which ship with GHC itself.
@@ -31,3 +34,13 @@ getCorePackages =
31 | length s > 2 && headEx s == '(' && lastEx s == ')' =
34 | length s > 2 && headEx s == '(' && lastEx s == ')' =
32 initEx $ tailEx s
35 initEx $ tailEx s
33 | otherwise = s
36 | otherwise = s
37+
38+-- | A list of executables that are shipped with GHC.
39+getCoreExecutables :: IO (Set ExeName)
40+getCoreExecutables = do
41+ mfp <- findExecutable "ghc"
42+ dir <-
43+ case mfp of
44+ Nothing -> error "No ghc executable found on PATH"
45+ Just fp -> return $ directory $ fpFromString fp
46+ (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir
Stackage2/PackageDescription.hs+20−14
@@ -40,13 +40,15 @@ instance Monoid SimpleTree where
40 (c ++ z)
40 (c ++ z)
41
41
42data SimpleExtra = SimpleExtra
42data SimpleExtra = SimpleExtra
43− { seTools :: Map PackageName VersionRange
43+ { seTools :: Map ExeName VersionRange
44+ , seProvidedExes :: Set ExeName
44 }
45 }
45 deriving Show
46 deriving Show
46instance Monoid SimpleExtra where
47instance Monoid SimpleExtra where
47− mempty = SimpleExtra mempty
48+ mempty = SimpleExtra mempty mempty
48− mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra
49+ mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra
49 (unionWith intersectVersionRanges a x)
50 (unionWith intersectVersionRanges a x)
51+ (b ++ y)
50
52
51getFlattenedComponent
53getFlattenedComponent
52 :: Bool -- ^ include test suites?
54 :: Bool -- ^ include test suites?
@@ -61,29 +63,33 @@ getSimpleTrees :: Bool -- ^ include test suites?
61 -> GenericPackageDescription
63 -> GenericPackageDescription
62 -> [SimpleTree]
64 -> [SimpleTree]
63getSimpleTrees includeTests includeBench gpd = concat
65getSimpleTrees includeTests includeBench gpd = concat
64− [ maybe [] (return . go libBuildInfo) $ condLibrary gpd
66+ [ maybe [] (return . go libBuildInfo mempty) $ condLibrary gpd
67+ , map (\(x, y) -> go buildInfo (singletonSet $ ExeName $ pack x) y)
65− , map (go buildInfo . snd) $ condExecutables gpd
68+ $ condExecutables gpd
66 , if includeTests
69 , if includeTests
67− then map (go testBuildInfo . snd) $ condTestSuites gpd
70+ then map (go testBuildInfo mempty . snd) $ condTestSuites gpd
68 else []
71 else []
69 , if includeBench
72 , if includeBench
70− then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd
73+ then map (go benchmarkBuildInfo mempty . snd) $ condBenchmarks gpd
71 else []
74 else []
72 ]
75 ]
73 where
76 where
74− go getExtra (CondNode dat deps comps) = SimpleTree
77+ go getBI exes (CondNode dat deps comps) = SimpleTree
75 { stDeps = unionsWith intersectVersionRanges
78 { stDeps = unionsWith intersectVersionRanges
76 $ map (\(Dependency x y) -> singletonMap x y) deps
79 $ map (\(Dependency x y) -> singletonMap x y) deps
77− , stConds = map (goComp getExtra) comps
80+ , stConds = map (goComp getBI exes) comps
78− , stExtra = toSimpleExtra $ getExtra dat
81+ , stExtra = toSimpleExtra (getBI dat) exes
79 }
82 }
80
83
81− goComp getExtra (cond, tree1, mtree2) =
84+ goComp getBI exes (cond, tree1, mtree2) =
82− (cond, go getExtra tree1, go getExtra <$> mtree2)
85+ (cond, go getBI exes tree1, go getBI exes <$> mtree2)
83
86
84− toSimpleExtra bi = SimpleExtra
87+ toSimpleExtra bi exes = SimpleExtra
85 { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)
88 { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)
86− $ \(Dependency name range) -> singletonMap name range
89+ $ \(Dependency name range) -> singletonMap
90+ (ExeName $ unPackageName name)
91+ range
92+ , seProvidedExes = exes
87 }
93 }
88
94
89data FlatComponent = FlatComponent
95data FlatComponent = FlatComponent
Stackage2/Prelude.hs+4
@@ -78,3 +78,7 @@ withCheckedProcess cp f = do
78
78
79newtype Maintainer = Maintainer { unMaintainer :: Text }
79newtype Maintainer = Maintainer { unMaintainer :: Text }
80 deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)
80 deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)
81+
82+-- | Name of an executable.
83+newtype ExeName = ExeName { unExeName :: Text }
84+ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)
test/Stackage2/CorePackagesSpec.hs+5
@@ -12,3 +12,8 @@ spec = do
12 m <- getCorePackages
12 m <- getCorePackages
13 forM_ (words "ghc containers base") $ \p ->
13 forM_ (words "ghc containers base") $ \p ->
14 m `shouldSatisfy` (member (PackageName p))
14 m `shouldSatisfy` (member (PackageName p))
15+ it "getCoreExecutables includes known executables" $ do
16+ s <- getCoreExecutables
17+ s `shouldSatisfy` member "ghc"
18+ s `shouldSatisfy` member "hsc2hs"
19+ s `shouldSatisfy` member "runghc"