diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index f1d19c13..3dd13d46 100644 --- a/Stackage2/BuildPlan.hs +++ b/Stackage2/BuildPlan.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} @@ -146,32 +148,76 @@ instance FromJSON TestState where newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent) newBuildPlan = liftIO $ do core <- getCorePackages + coreExes <- getCoreExecutables extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild - let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig -- FIXME extraOrig ==> extra - extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig + let toolMap = makeToolMap extraOrig + extra = populateUsers $ removeUnincluded toolMap extraOrig + toolNames :: [ExeName] + toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra + tools <- topologicalSortTools toolMap $ mapFromList $ do + exeName <- toolNames + guard $ exeName `notMember` coreExes + packageName <- maybe mempty setToList $ lookup exeName toolMap + packageBuild <- maybeToList $ lookup packageName extraOrig + return (packageName, packageBuild) return BuildPlan { bpCore = core - , bpTools = topologicalSort - $ filter (\(x, _) -> x `member` toolNames) - $ mapToList extra + , bpTools = tools , bpExtra = extra , bpGlobalFlags = defaultGlobalFlags } -topologicalSort :: [(PackageName, PackageBuild FlatComponent)] - -> Vector (PackageName, Version) -topologicalSort = fromList . fmap (fmap pbVersion) -- FIXME +makeToolMap :: Map PackageName (PackageBuild FlatComponent) + -> Map ExeName (Set PackageName) +makeToolMap = + unionsWith (++) . map go . mapToList + where + go (packageName, pb) = + foldMap go' $ seProvidedExes $ fcExtra $ pbDesc pb + where + go' exeName = singletonMap exeName (singletonSet packageName) -removeUnincluded :: Set PackageName -- ^ tool names +topologicalSortTools :: MonadThrow m + => Map ExeName (Set PackageName) + -> Map PackageName (PackageBuild FlatComponent) + -> m (Vector (PackageName, Version)) +topologicalSortTools toolMap = topologicalSort + pbVersion + (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . seTools . fcExtra . pbDesc) + +topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key) + => (value -> finalValue) + -> (value -> Set key) -- ^ deps + -> Map key value + -> m (Vector (key, finalValue)) +topologicalSort toFinal toDeps = + loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal) + where + removeSelfDeps k (deps, final) = (deleteSet k deps, final) + loop front toProcess | null toProcess = return $ pack $ front [] + loop front toProcess + | null noDeps = throwM $ NoEmptyDeps (map fst toProcess') + | otherwise = loop (front . noDeps') (mapFromList hasDeps) + where + toProcess' = fmap (first removeUnavailable) toProcess + allKeys = Map.keysSet toProcess + removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList + (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess' + noDeps' = (map (second snd) noDeps ++) + +data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) + deriving (Show, Typeable) +instance (Show key, Typeable key) => Exception (TopologicalSortException key) + +removeUnincluded :: Map ExeName (Set PackageName) -> Map PackageName (PackageBuild FlatComponent) -> Map PackageName (PackageBuild FlatComponent) -removeUnincluded toolNames orig = +removeUnincluded toolMap orig = mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig where included :: Set PackageName - included = flip execState mempty $ do + included = flip execState mempty $ mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints - mapM_ add toolNames -- FIXME remove this add name = do inc <- get @@ -179,8 +225,10 @@ removeUnincluded toolNames orig = put $ insertSet name inc case lookup name orig of Nothing -> return () - Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb - -- FIXME add tools here + Just pb -> do + mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb + forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $ + \exeName -> mapM_ add $ fromMaybe mempty $ lookup exeName toolMap populateUsers :: Map PackageName (PackageBuild FlatComponent) -> Map PackageName (PackageBuild FlatComponent) diff --git a/Stackage2/CorePackages.hs b/Stackage2/CorePackages.hs index a0687233..c70b210b 100644 --- a/Stackage2/CorePackages.hs +++ b/Stackage2/CorePackages.hs @@ -2,10 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} module Stackage2.CorePackages ( getCorePackages + , getCoreExecutables ) where import qualified Data.Text as T +import Filesystem (listDirectory) import Stackage2.Prelude +import System.Directory (findExecutable) -- | Get a @Map@ of all of the core packages. Core packages are defined as -- packages which ship with GHC itself. @@ -31,3 +34,13 @@ getCorePackages = | length s > 2 && headEx s == '(' && lastEx s == ')' = initEx $ tailEx s | otherwise = s + +-- | A list of executables that are shipped with GHC. +getCoreExecutables :: IO (Set ExeName) +getCoreExecutables = do + mfp <- findExecutable "ghc" + dir <- + case mfp of + Nothing -> error "No ghc executable found on PATH" + Just fp -> return $ directory $ fpFromString fp + (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index c22dfeb1..b228a060 100644 --- a/Stackage2/PackageDescription.hs +++ b/Stackage2/PackageDescription.hs @@ -40,13 +40,15 @@ instance Monoid SimpleTree where (c ++ z) data SimpleExtra = SimpleExtra - { seTools :: Map PackageName VersionRange + { seTools :: Map ExeName VersionRange + , seProvidedExes :: Set ExeName } deriving Show instance Monoid SimpleExtra where - mempty = SimpleExtra mempty - mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra + mempty = SimpleExtra mempty mempty + mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra (unionWith intersectVersionRanges a x) + (b ++ y) getFlattenedComponent :: Bool -- ^ include test suites? @@ -61,29 +63,33 @@ getSimpleTrees :: Bool -- ^ include test suites? -> GenericPackageDescription -> [SimpleTree] getSimpleTrees includeTests includeBench gpd = concat - [ maybe [] (return . go libBuildInfo) $ condLibrary gpd - , map (go buildInfo . snd) $ condExecutables gpd + [ maybe [] (return . go libBuildInfo mempty) $ condLibrary gpd + , map (\(x, y) -> go buildInfo (singletonSet $ ExeName $ pack x) y) + $ condExecutables gpd , if includeTests - then map (go testBuildInfo . snd) $ condTestSuites gpd + then map (go testBuildInfo mempty . snd) $ condTestSuites gpd else [] , if includeBench - then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd + then map (go benchmarkBuildInfo mempty . snd) $ condBenchmarks gpd else [] ] where - go getExtra (CondNode dat deps comps) = SimpleTree + go getBI exes (CondNode dat deps comps) = SimpleTree { stDeps = unionsWith intersectVersionRanges $ map (\(Dependency x y) -> singletonMap x y) deps - , stConds = map (goComp getExtra) comps - , stExtra = toSimpleExtra $ getExtra dat + , stConds = map (goComp getBI exes) comps + , stExtra = toSimpleExtra (getBI dat) exes } - goComp getExtra (cond, tree1, mtree2) = - (cond, go getExtra tree1, go getExtra <$> mtree2) + goComp getBI exes (cond, tree1, mtree2) = + (cond, go getBI exes tree1, go getBI exes <$> mtree2) - toSimpleExtra bi = SimpleExtra + toSimpleExtra bi exes = SimpleExtra { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi) - $ \(Dependency name range) -> singletonMap name range + $ \(Dependency name range) -> singletonMap + (ExeName $ unPackageName name) + range + , seProvidedExes = exes } data FlatComponent = FlatComponent diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index c57be432..9250f5a9 100644 --- a/Stackage2/Prelude.hs +++ b/Stackage2/Prelude.hs @@ -78,3 +78,7 @@ withCheckedProcess cp f = do newtype Maintainer = Maintainer { unMaintainer :: Text } deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON) + +-- | Name of an executable. +newtype ExeName = ExeName { unExeName :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) diff --git a/test/Stackage2/CorePackagesSpec.hs b/test/Stackage2/CorePackagesSpec.hs index 1bf7465d..bdcde94d 100644 --- a/test/Stackage2/CorePackagesSpec.hs +++ b/test/Stackage2/CorePackagesSpec.hs @@ -12,3 +12,8 @@ spec = do m <- getCorePackages forM_ (words "ghc containers base") $ \p -> m `shouldSatisfy` (member (PackageName p)) + it "getCoreExecutables includes known executables" $ do + s <- getCoreExecutables + s `shouldSatisfy` member "ghc" + s `shouldSatisfy` member "hsc2hs" + s `shouldSatisfy` member "runghc"