Correct discovery of build tools deps

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)

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

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

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)

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"