31efd7e · stackage · git.iko.soy

git.iko.soy/stackage

Correct discovery of build tools deps

commit31efd7eb20ffe41825f2ac10e434caf9e9bb3f82 authorMichael Snoyman <michael@snoyman.com> dateSun 7 Dec 2014, 11:42 (12 years ago) parent2d4207a

5 files changed+104−28

compare with master

unifiedsplit

Stackage2/BuildPlan.hs+62−14 Stackage2/CorePackages.hs+13 Stackage2/PackageDescription.hs+20−14 Stackage2/Prelude.hs+4 test/Stackage2/CorePackagesSpec.hs+5

Stackage2/BuildPlan.hs+62−14

@@ -1,4 +1,6 @@

11{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE TupleSections #-}

24{-# LANGUAGE RecordWildCards #-}

35{-# LANGUAGE OverloadedStrings #-}

46{-# LANGUAGE DeriveFunctor #-}

@@ -146,32 +148,76 @@ instance FromJSON TestState where

146148newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)

147149newBuildPlan = liftIO $ do

148150 core <- getCorePackages

151+ coreExes <- getCoreExecutables

149152 extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild

150− let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig -- FIXME extraOrig ==> extra

151− extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig

153+ let toolMap = makeToolMap extraOrig

154+ extra = populateUsers $ removeUnincluded toolMap extraOrig

155+ toolNames :: [ExeName]

156+ toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra

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)

152163 return BuildPlan

153164 { bpCore = core

154− , bpTools = topologicalSort

155− $ filter (\(x, _) -> x `member` toolNames)

156− $ mapToList extra

165+ , bpTools = tools

157166 , bpExtra = extra

158167 , bpGlobalFlags = defaultGlobalFlags

159168 }

160169

161−topologicalSort :: [(PackageName, PackageBuild FlatComponent)]

162− -> Vector (PackageName, Version)

163−topologicalSort = fromList . fmap (fmap pbVersion) -- FIXME

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)

182+ -> Map PackageName (PackageBuild FlatComponent)

183+ -> m (Vector (PackageName, Version))

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)

164211

165−removeUnincluded :: Set PackageName -- ^ tool names

212+removeUnincluded :: Map ExeName (Set PackageName)

166213 -> Map PackageName (PackageBuild FlatComponent)

167214 -> Map PackageName (PackageBuild FlatComponent)

168−removeUnincluded toolNames orig =

215+removeUnincluded toolMap orig =

169216 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig

170217 where

171218 included :: Set PackageName

172− included = flip execState mempty $ do

219+ included = flip execState mempty $

173220 mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints

174− mapM_ add toolNames -- FIXME remove this

175221

176222 add name = do

177223 inc <- get

@@ -179,8 +225,10 @@ removeUnincluded toolNames orig =

179225 put $ insertSet name inc

180226 case lookup name orig of

181227 Nothing -> return ()

182− Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb

183− -- FIXME add tools here

228+ Just pb -> do

229+ mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb

230+ forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $

231+ \exeName -> mapM_ add $ fromMaybe mempty $ lookup exeName toolMap

184232

185233populateUsers :: Map PackageName (PackageBuild FlatComponent)

186234 -> Map PackageName (PackageBuild FlatComponent)

Stackage2/CorePackages.hs+13

@@ -2,10 +2,13 @@

22{-# LANGUAGE OverloadedStrings #-}

33module Stackage2.CorePackages

44 ( getCorePackages

5+ , getCoreExecutables

56 ) where

78import qualified Data.Text as T

9+import Filesystem (listDirectory)

810import Stackage2.Prelude

11+import System.Directory (findExecutable)

912

1013-- | Get a @Map@ of all of the core packages. Core packages are defined as

1114-- packages which ship with GHC itself.

@@ -31,3 +34,13 @@ getCorePackages =

3134 | length s > 2 && headEx s == '(' && lastEx s == ')' =

3235 initEx $ tailEx s

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

4040 (c ++ z)

4141

4242data SimpleExtra = SimpleExtra

43− { seTools :: Map PackageName VersionRange

43+ { seTools :: Map ExeName VersionRange

44+ , seProvidedExes :: Set ExeName

4445 }

4546 deriving Show

4647instance Monoid SimpleExtra where

47− mempty = SimpleExtra mempty

48− mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra

48+ mempty = SimpleExtra mempty mempty

49+ mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra

4950 (unionWith intersectVersionRanges a x)

51+ (b ++ y)

5052

5153getFlattenedComponent

5254 :: Bool -- ^ include test suites?

@@ -61,29 +63,33 @@ getSimpleTrees :: Bool -- ^ include test suites?

6163 -> GenericPackageDescription

6264 -> [SimpleTree]

6365getSimpleTrees includeTests includeBench gpd = concat

64− [ maybe [] (return . go libBuildInfo) $ condLibrary gpd

65− , map (go buildInfo . snd) $ condExecutables gpd

66+ [ maybe [] (return . go libBuildInfo mempty) $ condLibrary gpd

67+ , map (\(x, y) -> go buildInfo (singletonSet $ ExeName $ pack x) y)

68+ $ condExecutables gpd

6669 , if includeTests

67− then map (go testBuildInfo . snd) $ condTestSuites gpd

70+ then map (go testBuildInfo mempty . snd) $ condTestSuites gpd

6871 else []

6972 , if includeBench

70− then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd

73+ then map (go benchmarkBuildInfo mempty . snd) $ condBenchmarks gpd

7174 else []

7275 ]

7376 where

74− go getExtra (CondNode dat deps comps) = SimpleTree

77+ go getBI exes (CondNode dat deps comps) = SimpleTree

7578 { stDeps = unionsWith intersectVersionRanges

7679 $ map (\(Dependency x y) -> singletonMap x y) deps

77− , stConds = map (goComp getExtra) comps

78− , stExtra = toSimpleExtra $ getExtra dat

80+ , stConds = map (goComp getBI exes) comps

81+ , stExtra = toSimpleExtra (getBI dat) exes

7982 }

8083

81− goComp getExtra (cond, tree1, mtree2) =

82− (cond, go getExtra tree1, go getExtra <$> mtree2)

84+ goComp getBI exes (cond, tree1, mtree2) =

85+ (cond, go getBI exes tree1, go getBI exes <$> mtree2)

8386

84− toSimpleExtra bi = SimpleExtra

87+ toSimpleExtra bi exes = SimpleExtra

8588 { 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

8793 }

8894

8995data FlatComponent = FlatComponent

Stackage2/Prelude.hs+4

@@ -78,3 +78,7 @@ withCheckedProcess cp f = do

7878

7979newtype Maintainer = Maintainer { unMaintainer :: Text }

8080 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

1212 m <- getCorePackages

1313 forM_ (words "ghc containers base") $ \p ->

1414 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"