{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.DependencyGraph
License     : BSD-3-Clause

Module exporting a function to create a pruned dependency graph given
a t'DotOpts' value.
-}

module Stack.DependencyGraph
  ( createPrunedDependencyGraph
  , resolveDependencies
  , pruneGraph
  ) where

import qualified Data.Foldable as F
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Traversable as T
import           Distribution.License ( License (..) )
import qualified Distribution.PackageDescription as PD
import           Distribution.Types.PackageName ( mkPackageName )
import           Path ( parent )
import           Stack.Build ( loadPackage )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source
                   ( loadCommonPackage, loadLocalPackage, loadSourceMap )
import           Stack.Build.Target( NeedTargets (..), parseTargets )
import           Stack.Package ( Package (..), setOfPackageDeps )
import           Stack.Prelude hiding ( Display (..), pkgName, loadPackage )
import qualified Stack.Prelude ( pkgName )
import           Stack.Runners
                   ( ShouldReexec (..), withBuildConfig, withConfig
                   , withEnvConfig
                   )
import           Stack.SourceMap
                   ( globalsFromHints, mkProjectPackage, pruneGlobals )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.BuildOptsMonoid
                   ( buildOptsMonoidBenchmarksL, buildOptsMonoidTestsL )
import           Stack.Types.Compiler ( ActualCompiler, wantedToActual )
import           Stack.Types.DependencyTree ( DependencyGraph, DotPayload (..) )
import           Stack.Types.DotConfig ( DotConfig (..) )
import           Stack.Types.DotOpts ( DotOpts (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig ( EnvConfig (..), HasSourceMap (..) )
import           Stack.Types.GhcPkgId
                   ( GhcPkgId, ghcPkgIdString, parseGhcPkgId )
import           Stack.Types.GlobalOpts ( globalOptsBuildOptsMonoidL )
import           Stack.Types.Package ( LocalPackage (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                   , SMActual (..), SMWanted (..), SourceMap (..)
                   )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.DependencyGraph" module.

newtype DependencyGraphException
  = DependencyNotFoundBug GhcPkgId
  deriving Int -> DependencyGraphException -> ShowS
[DependencyGraphException] -> ShowS
DependencyGraphException -> String
(Int -> DependencyGraphException -> ShowS)
-> (DependencyGraphException -> String)
-> ([DependencyGraphException] -> ShowS)
-> Show DependencyGraphException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependencyGraphException -> ShowS
showsPrec :: Int -> DependencyGraphException -> ShowS
$cshow :: DependencyGraphException -> String
show :: DependencyGraphException -> String
$cshowList :: [DependencyGraphException] -> ShowS
showList :: [DependencyGraphException] -> ShowS
Show

instance Exception DependencyGraphException where
  displayException :: DependencyGraphException -> String
displayException (DependencyNotFoundBug GhcPkgId
depId) = String -> ShowS
bugReport String
"[S-7071]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Expected to find "
    , GhcPkgId -> String
ghcPkgIdString GhcPkgId
depId
    , String
" in global DB."
    ]

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.DependencyGraph" module.

newtype DependencyGraphPrettyException
  = PackageNotFound PackageName
  deriving Int -> DependencyGraphPrettyException -> ShowS
[DependencyGraphPrettyException] -> ShowS
DependencyGraphPrettyException -> String
(Int -> DependencyGraphPrettyException -> ShowS)
-> (DependencyGraphPrettyException -> String)
-> ([DependencyGraphPrettyException] -> ShowS)
-> Show DependencyGraphPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependencyGraphPrettyException -> ShowS
showsPrec :: Int -> DependencyGraphPrettyException -> ShowS
$cshow :: DependencyGraphPrettyException -> String
show :: DependencyGraphPrettyException -> String
$cshowList :: [DependencyGraphPrettyException] -> ShowS
showList :: [DependencyGraphPrettyException] -> ShowS
Show

instance Pretty DependencyGraphPrettyException where

  pretty :: DependencyGraphPrettyException -> StyleDoc
pretty (PackageNotFound PackageName
pkgName) =
       StyleDoc
"[S-7151]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"The package"
         , Style -> StyleDoc -> StyleDoc
style Style
Error (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
pkgName
         , String -> StyleDoc
flow String
"was not identified as a project package, an extra-dep, or a \
                \package specified by the snapshot."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Command"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack build --dry-run"
         , String -> StyleDoc
flow String
"for information about why Stack fails to construct a build \
                \plan."
         ]

instance Exception DependencyGraphPrettyException

-- | Create the dependency graph and also prune it as specified in the dot

-- options. Returns a set of local names and a map from package names to

-- dependencies.

createPrunedDependencyGraph ::
     DotOpts
  -> RIO
       Runner
       ( ActualCompiler
       , Set PackageName
       , DependencyGraph
       )
createPrunedDependencyGraph :: DotOpts
-> RIO Runner (ActualCompiler, Set PackageName, DependencyGraph)
createPrunedDependencyGraph DotOpts
dotOpts = DotOpts
-> RIO DotConfig (ActualCompiler, Set PackageName, DependencyGraph)
-> RIO Runner (ActualCompiler, Set PackageName, DependencyGraph)
forall a. DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
dotOpts (RIO DotConfig (ActualCompiler, Set PackageName, DependencyGraph)
 -> RIO Runner (ActualCompiler, Set PackageName, DependencyGraph))
-> RIO DotConfig (ActualCompiler, Set PackageName, DependencyGraph)
-> RIO Runner (ActualCompiler, Set PackageName, DependencyGraph)
forall a b. (a -> b) -> a -> b
$ do
  localNames <- Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Set PackageName) DotConfig (Set PackageName)
 -> RIO DotConfig (Set PackageName))
-> Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Set PackageName) BuildConfig)
-> DotConfig -> Const (Set PackageName) DotConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' DotConfig BuildConfig
buildConfigL ((BuildConfig -> Const (Set PackageName) BuildConfig)
 -> DotConfig -> Const (Set PackageName) DotConfig)
-> ((Set PackageName -> Const (Set PackageName) (Set PackageName))
    -> BuildConfig -> Const (Set PackageName) BuildConfig)
-> Getting (Set PackageName) DotConfig (Set PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Set PackageName)
-> SimpleGetter BuildConfig (Set PackageName)
forall s a. (s -> a) -> SimpleGetter s a
to (Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName ProjectPackage -> Set PackageName)
-> (BuildConfig -> Map PackageName ProjectPackage)
-> BuildConfig
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.smWanted.project))
  logDebug "Creating dependency graph"
  (compiler, resultGraph) <- createDependencyGraph dotOpts
  let pkgsToPrune = if DotOpts
dotOpts.includeBase
                      then DotOpts
dotOpts.prune
                      else PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
"base" DotOpts
dotOpts.prune
      prunedGraph = Set PackageName
-> Set PackageName -> DependencyGraph -> DependencyGraph
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Foldable g, Eq a) =>
f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph Set PackageName
localNames Set PackageName
pkgsToPrune DependencyGraph
resultGraph
  logDebug "Returning pruned dependency graph"
  pure (compiler, localNames, prunedGraph)

-- Plumbing for --test and --bench flags

withDotConfig ::
     DotOpts
  -> RIO DotConfig a
  -> RIO Runner a
withDotConfig :: forall a. DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
opts RIO DotConfig a
inner =
  (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall a. (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) (RIO Runner a -> RIO Runner a) -> RIO Runner a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$
    if DotOpts
opts.globalHints
      then ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config a -> RIO Runner a) -> RIO Config a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ RIO BuildConfig a -> RIO Config a
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig RIO BuildConfig a
withGlobalHints
      else ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec RIO Config a
withReal
 where
  withGlobalHints :: RIO BuildConfig a
withGlobalHints = do
    buildConfig <- Getting BuildConfig BuildConfig BuildConfig
-> RIO BuildConfig BuildConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildConfig BuildConfig BuildConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' BuildConfig BuildConfig
buildConfigL
    globals <- globalsFromHints buildConfig.smWanted.compiler
    fakeGhcPkgId <- parseGhcPkgId "ignored"
    actual <- either throwIO pure $
      wantedToActual buildConfig.smWanted.compiler
    let smActual = SMActual
          { compiler :: ActualCompiler
compiler = ActualCompiler
actual
          , project :: Map PackageName ProjectPackage
project = BuildConfig
buildConfig.smWanted.project
          , deps :: Map PackageName DepPackage
deps =  BuildConfig
buildConfig.smWanted.deps
          , globals :: Map PackageName DumpPackage
globals = (PackageName -> Version -> DumpPackage)
-> Map PackageName Version -> Map PackageName DumpPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PackageName -> Version -> DumpPackage
toDump Map PackageName Version
globals
          }
        toDump :: PackageName -> Version -> DumpPackage
        toDump PackageName
pkgName Version
pkgVersion = DumpPackage
          { ghcPkgId :: GhcPkgId
ghcPkgId = GhcPkgId
fakeGhcPkgId
          , packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
              { PackageName
pkgName :: PackageName
pkgName :: PackageName
pkgName
              , Version
pkgVersion :: Version
pkgVersion :: Version
pkgVersion
              }
          , sublib :: Maybe SublibDump
sublib = Maybe SublibDump
forall a. Maybe a
Nothing
          , license :: Maybe License
license = Maybe License
forall a. Maybe a
Nothing
          , libDirs :: [String]
libDirs = []
          , libraries :: [Text]
libraries = []
          , hasExposedModules :: Bool
hasExposedModules = Bool
True
          , exposedModules :: Set ModuleName
exposedModules = Set ModuleName
forall a. Monoid a => a
mempty
          , depends :: [GhcPkgId]
depends = []
          , haddockInterfaces :: [String]
haddockInterfaces = []
          , haddockHtml :: Maybe String
haddockHtml = Maybe String
forall a. Maybe a
Nothing
          , isExposed :: Bool
isExposed = Bool
True
          }
        actualPkgs =
          Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet SMActual DumpPackage
smActual.deps Set PackageName -> Set PackageName -> Set PackageName
forall a. Semigroup a => a -> a -> a
<> Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet SMActual DumpPackage
smActual.project
        prunedActual = SMActual DumpPackage
smActual
          { globals = pruneGlobals smActual.globals actualPkgs }
    targets <- parseTargets NeedTargets False boptsCLI prunedActual
    logDebug "Loading source map"
    sourceMap <- loadSourceMap targets boptsCLI smActual
    let dc = DotConfig
          { BuildConfig
buildConfig :: BuildConfig
buildConfig :: BuildConfig
buildConfig
          , SourceMap
sourceMap :: SourceMap
sourceMap :: SourceMap
sourceMap
          , globalDump :: [DumpPackage]
globalDump = Map PackageName DumpPackage -> [DumpPackage]
forall a. Map PackageName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SMActual DumpPackage
smActual.globals
          }
    logDebug "DotConfig fully loaded"
    runRIO dc inner

  withReal :: RIO Config a
withReal = NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
NeedTargets BuildOptsCLI
boptsCLI (RIO EnvConfig a -> RIO Config a)
-> RIO EnvConfig a -> RIO Config a
forall a b. (a -> b) -> a -> b
$ do
    envConfig <- RIO EnvConfig EnvConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    let sourceMap = EnvConfig
envConfig.sourceMap
    installMap <- toInstallMap sourceMap
    (_, globalDump, _, _) <- getInstalled installMap
    let dc = DotConfig
          { buildConfig :: BuildConfig
buildConfig = EnvConfig
envConfig.buildConfig
          , SourceMap
sourceMap :: SourceMap
sourceMap :: SourceMap
sourceMap
          , [DumpPackage]
globalDump :: [DumpPackage]
globalDump :: [DumpPackage]
globalDump
          }
    runRIO dc inner

  boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
    { targetsCLI = opts.dotTargets
    , flags = opts.flags
    }
  modifyGO :: GlobalOpts -> GlobalOpts
modifyGO =
      ( if DotOpts
opts.testTargets
          then
            ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set
              ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidTestsL)
              (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
          else GlobalOpts -> GlobalOpts
forall a. a -> a
id
      )
    (GlobalOpts -> GlobalOpts)
-> (GlobalOpts -> GlobalOpts) -> GlobalOpts -> GlobalOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( if DotOpts
opts.benchTargets
          then
            ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set
              ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidBenchmarksL)
              (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
          else GlobalOpts -> GlobalOpts
forall a. a -> a
id
      )

-- | Create the dependency graph, the result is a map from a package name to a

-- tuple of dependencies and payload if available. This function mainly gathers

-- the required arguments for @resolveDependencies@.

createDependencyGraph ::
     DotOpts
  -> RIO DotConfig (ActualCompiler, DependencyGraph)
createDependencyGraph :: DotOpts -> RIO DotConfig (ActualCompiler, DependencyGraph)
createDependencyGraph DotOpts
dotOpts = do
  sourceMap <- Getting SourceMap DotConfig SourceMap -> RIO DotConfig SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SourceMap DotConfig SourceMap
forall env. HasSourceMap env => Lens' env SourceMap
Lens' DotConfig SourceMap
sourceMapL
  locals <- for (toList sourceMap.project) loadLocalPackage
  let graph = [(PackageName, (Set PackageName, DotPayload))] -> DependencyGraph
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, (Set PackageName, DotPayload))] -> DependencyGraph)
-> [(PackageName, (Set PackageName, DotPayload))]
-> DependencyGraph
forall a b. (a -> b) -> a -> b
$
        DotOpts
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies DotOpts
dotOpts ((LocalPackage -> Bool) -> [LocalPackage] -> [LocalPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (.wanted) [LocalPackage]
locals)
  globalDump <- view $ to (.globalDump)
  -- TODO: Can there be multiple entries for wired-in-packages? If so, this will

  -- choose one arbitrarily..

  let globalDumpMap = [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, DumpPackage)] -> Map PackageName DumpPackage)
-> [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall a b. (a -> b) -> a -> b
$
        (DumpPackage -> (PackageName, DumpPackage))
-> [DumpPackage] -> [(PackageName, DumpPackage)]
forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (PackageIdentifier -> PackageName
Stack.Prelude.pkgName DumpPackage
dp.packageIdent, DumpPackage
dp)) [DumpPackage]
globalDump
      globalIdMap =
        [(GhcPkgId, PackageIdentifier)] -> Map GhcPkgId PackageIdentifier
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GhcPkgId, PackageIdentifier)] -> Map GhcPkgId PackageIdentifier)
-> [(GhcPkgId, PackageIdentifier)]
-> Map GhcPkgId PackageIdentifier
forall a b. (a -> b) -> a -> b
$ (DumpPackage -> (GhcPkgId, PackageIdentifier))
-> [DumpPackage] -> [(GhcPkgId, PackageIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map ((.ghcPkgId) (DumpPackage -> GhcPkgId)
-> (DumpPackage -> PackageIdentifier)
-> DumpPackage
-> (GhcPkgId, PackageIdentifier)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (.packageIdent)) [DumpPackage]
globalDump
  let depLoader =
        SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName
    -> Version
    -> PackageLocationImmutable
    -> Map FlagName Bool
    -> [Text]
    -> [Text]
    -> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader SourceMap
sourceMap Map PackageName DumpPackage
globalDumpMap Map GhcPkgId PackageIdentifier
globalIdMap PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
forall {env}.
(HasBuildConfig env, HasSourceMap env) =>
PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO env (Set PackageName, DotPayload)
loadPackageDeps
      loadPackageDeps PackageName
name Version
version PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts
        -- Skip packages that can't be loaded - see

        -- https://github.com/commercialhaskell/stack/issues/2967

        | PackageName
name PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String -> PackageName
mkPackageName String
"rts", String -> PackageName
mkPackageName String
"ghc"] =
            (Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ( Set PackageName
forall a. Set a
Set.empty
              , DotPayload
                  { version :: Maybe Version
version = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
                  , license :: Maybe (Either License License)
license = Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ License -> Either License License
forall a b. b -> Either a b
Right License
BSD3
                  , location :: Maybe PackageLocation
location = Maybe PackageLocation
forall a. Maybe a
Nothing
                  }
              )
        | Bool
otherwise = (Package -> (Set PackageName, DotPayload))
-> RIO env Package -> RIO env (Set PackageName, DotPayload)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (Package -> Set PackageName
setOfPackageDeps (Package -> Set PackageName)
-> (Package -> DotPayload)
-> Package
-> (Set PackageName, DotPayload)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PackageLocationImmutable -> Package -> DotPayload
forall {r}.
(HasField "version" r Version,
 HasField "license" r (Either License License)) =>
PackageLocationImmutable -> r -> DotPayload
makePayload PackageLocationImmutable
loc)
            (PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
loadPackage PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts)
  resultGraph <- resolveDependencies dotOpts.dependencyDepth graph depLoader
  pure (sourceMap.compiler, resultGraph)
 where
  makePayload :: PackageLocationImmutable -> r -> DotPayload
makePayload PackageLocationImmutable
loc r
pkg = DotPayload
    { version :: Maybe Version
version = Version -> Maybe Version
forall a. a -> Maybe a
Just r
pkg.version
    , license :: Maybe (Either License License)
license = Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just r
pkg.license
    , location :: Maybe PackageLocation
location = PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just (PackageLocation -> Maybe PackageLocation)
-> PackageLocation -> Maybe PackageLocation
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
loc
    }

-- | Resolve the direct (depth 0) external dependencies of the given local

-- packages (assumed to come from project packages)

projectPackageDependencies ::
     DotOpts
  -> [LocalPackage]
  -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies :: DotOpts
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies DotOpts
dotOpts [LocalPackage]
locals =
  (LocalPackage -> (PackageName, (Set PackageName, DotPayload)))
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
forall a b. (a -> b) -> [a] -> [b]
map
    ( \LocalPackage
lp -> let pkg :: Package
pkg = LocalPackage -> Package
localPackageToPackage LocalPackage
lp
                 pkgDir :: Path Abs Dir
pkgDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent LocalPackage
lp.cabalFP
                 packageDepsSet :: Set PackageName
packageDepsSet = Package -> Set PackageName
setOfPackageDeps Package
pkg
                 loc :: PackageLocation
loc = ResolvedPath Dir -> PackageLocation
PLMutable (ResolvedPath Dir -> PackageLocation)
-> ResolvedPath Dir -> PackageLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath
                   { resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath Text
"N/A"
                   , resolvedAbsolute :: Path Abs Dir
resolvedAbsolute = Path Abs Dir
pkgDir
                   }
             in  (Package
pkg.name, (Package -> Set PackageName -> Set PackageName
deps Package
pkg Set PackageName
packageDepsSet, Package -> PackageLocation -> DotPayload
forall {r}.
(HasField "version" r Version,
 HasField "license" r (Either License License)) =>
r -> PackageLocation -> DotPayload
lpPayload Package
pkg PackageLocation
loc))
    )
    [LocalPackage]
locals
 where
  deps :: Package -> Set PackageName -> Set PackageName
deps Package
pkg Set PackageName
packageDepsSet = if DotOpts
dotOpts.includeExternal
    then PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.delete Package
pkg.name Set PackageName
packageDepsSet
    else Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set PackageName
localNames Set PackageName
packageDepsSet
  localNames :: Set PackageName
localNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (LocalPackage -> PackageName) -> [LocalPackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (.package.name) [LocalPackage]
locals
  lpPayload :: r -> PackageLocation -> DotPayload
lpPayload r
pkg PackageLocation
loc =  DotPayload
    { version :: Maybe Version
version = Version -> Maybe Version
forall a. a -> Maybe a
Just r
pkg.version
    , license :: Maybe (Either License License)
license = Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just r
pkg.license
    , location :: Maybe PackageLocation
location = PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just PackageLocation
loc
    }

-- | Given a SourceMap and a dependency loader, load the set of dependencies for

-- a package

createDepLoader ::
     SourceMap
  -> Map PackageName DumpPackage
  -> Map GhcPkgId PackageIdentifier
  -> (  PackageName
     -> Version
     -> PackageLocationImmutable
     -> Map FlagName Bool
     -> [Text]
     -> [Text]
     -> RIO DotConfig (Set PackageName, DotPayload)
     )
  -> PackageName
  -> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader :: SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName
    -> Version
    -> PackageLocationImmutable
    -> Map FlagName Bool
    -> [Text]
    -> [Text]
    -> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader SourceMap
sourceMap Map PackageName DumpPackage
globalDumpMap Map GhcPkgId PackageIdentifier
globalIdMap PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
loadPackageDeps PackageName
pkgName =
  RIO DotConfig (Set PackageName, DotPayload)
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. a -> Maybe a -> a
fromMaybe (DependencyGraphPrettyException
-> RIO DotConfig (Set PackageName, DotPayload)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (DependencyGraphPrettyException
 -> RIO DotConfig (Set PackageName, DotPayload))
-> DependencyGraphPrettyException
-> RIO DotConfig (Set PackageName, DotPayload)
forall a b. (a -> b) -> a -> b
$ PackageName -> DependencyGraphPrettyException
PackageNotFound PackageName
pkgName)
    (Maybe (RIO DotConfig (Set PackageName, DotPayload))
projectPackageDeps Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RIO DotConfig (Set PackageName, DotPayload))
dependencyDeps Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RIO DotConfig (Set PackageName, DotPayload))
globalDeps)
 where
  projectPackageDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
projectPackageDeps = ProjectPackage -> RIO DotConfig (Set PackageName, DotPayload)
forall {env} {r}.
(HasBuildConfig env, HasSourceMap env,
 HasField "projectCommon" r CommonPackage) =>
r -> RIO env (Set PackageName, DotPayload)
loadDeps (ProjectPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe ProjectPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName SourceMap
sourceMap.project
   where
    loadDeps :: r -> RIO env (Set PackageName, DotPayload)
loadDeps r
pp = do
      pkg <- CommonPackage -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage r
pp.projectCommon
      pure (setOfPackageDeps pkg, payloadFromLocal pkg Nothing)

  dependencyDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
dependencyDeps =
    DepPackage -> RIO DotConfig (Set PackageName, DotPayload)
loadDeps (DepPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe DepPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName SourceMap
sourceMap.deps
   where
    loadDeps :: DepPackage -> RIO DotConfig (Set PackageName, DotPayload)
loadDeps DepPackage{ location :: DepPackage -> PackageLocation
location = PLMutable ResolvedPath Dir
dir } = do
      pp <- PrintWarnings
-> ResolvedPath Dir -> Bool -> RIO DotConfig ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
dir Bool
False
      pkg <- loadCommonPackage pp.projectCommon
      pure (setOfPackageDeps pkg, payloadFromLocal pkg (Just $ PLMutable dir))

    loadDeps dp :: DepPackage
dp@DepPackage{ location :: DepPackage -> PackageLocation
location = PLImmutable PackageLocationImmutable
loc } = do
      let common :: CommonPackage
common = DepPackage
dp.depCommon
      gpd <- IO GenericPackageDescription
-> RIO DotConfig GenericPackageDescription
forall a. IO a -> RIO DotConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO CommonPackage
common.gpd
      let PackageIdentifier name version =
            PD.package $ PD.packageDescription gpd
          flags = CommonPackage
common.flags
          ghcOptions = CommonPackage
common.ghcOptions
          cabalConfigOpts = CommonPackage
common.cabalConfigOpts
      assert
        (pkgName == name)
        (loadPackageDeps pkgName version loc flags ghcOptions cabalConfigOpts)

  -- If package is a global package, use info from ghc-pkg (#4324, #3084)

  globalDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
globalDeps =
    (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. a -> RIO DotConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Set PackageName, DotPayload)
 -> RIO DotConfig (Set PackageName, DotPayload))
-> (DumpPackage -> (Set PackageName, DotPayload))
-> DumpPackage
-> RIO DotConfig (Set PackageName, DotPayload)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> (Set PackageName, DotPayload)
getDepsFromDump (DumpPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe DumpPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DumpPackage -> Maybe DumpPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName Map PackageName DumpPackage
globalDumpMap
   where
    getDepsFromDump :: DumpPackage -> (Set PackageName, DotPayload)
getDepsFromDump DumpPackage
dump = ([PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList [PackageName]
deps, DumpPackage -> DotPayload
forall {r}.
(HasField "packageIdent" r PackageIdentifier,
 HasField "license" r (Maybe License)) =>
r -> DotPayload
payloadFromDump DumpPackage
dump)
     where
      deps :: [PackageName]
deps = (GhcPkgId -> PackageName) -> [GhcPkgId] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map GhcPkgId -> PackageName
ghcIdToPackageName DumpPackage
dump.depends
      ghcIdToPackageName :: GhcPkgId -> PackageName
ghcIdToPackageName GhcPkgId
depId =
        PackageName
-> (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier
-> PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (DependencyGraphException -> PackageName
forall e a. Exception e => e -> a
impureThrow (DependencyGraphException -> PackageName)
-> DependencyGraphException -> PackageName
forall a b. (a -> b) -> a -> b
$ GhcPkgId -> DependencyGraphException
DependencyNotFoundBug GhcPkgId
depId)
          PackageIdentifier -> PackageName
Stack.Prelude.pkgName
          (GhcPkgId
-> Map GhcPkgId PackageIdentifier -> Maybe PackageIdentifier
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GhcPkgId
depId Map GhcPkgId PackageIdentifier
globalIdMap)

  payloadFromLocal :: r -> Maybe PackageLocation -> DotPayload
payloadFromLocal r
pkg Maybe PackageLocation
location = DotPayload
    { version :: Maybe Version
version = Version -> Maybe Version
forall a. a -> Maybe a
Just r
pkg.version
    , license :: Maybe (Either License License)
license = Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just r
pkg.license
    , Maybe PackageLocation
location :: Maybe PackageLocation
location :: Maybe PackageLocation
location
    }

  payloadFromDump :: r -> DotPayload
payloadFromDump r
dp = DotPayload
    { version :: Maybe Version
version = Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Version
pkgVersion r
dp.packageIdent
    , license :: Maybe (Either License License)
license = License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> Maybe License -> Maybe (Either License License)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r
dp.license
    , location :: Maybe PackageLocation
location = Maybe PackageLocation
forall a. Maybe a
Nothing
    }

-- | Resolve the dependency graph up to (Just depth) or until fixpoint is

-- reached

resolveDependencies ::
     (Applicative m, Monad m)
  => Maybe Int
  -> DependencyGraph
  -> (PackageName -> m (Set PackageName, DotPayload))
  -> m DependencyGraph
resolveDependencies :: forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> DependencyGraph
-> (PackageName -> m (Set PackageName, DotPayload))
-> m DependencyGraph
resolveDependencies (Just Int
0) DependencyGraph
graph PackageName -> m (Set PackageName, DotPayload)
_ = DependencyGraph -> m DependencyGraph
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DependencyGraph
graph
resolveDependencies Maybe Int
limit DependencyGraph
graph PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps = do
  let values :: Set PackageName
values = [Set PackageName] -> Set PackageName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> [(Set PackageName, DotPayload)] -> [Set PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DependencyGraph -> [(Set PackageName, DotPayload)]
forall k a. Map k a -> [a]
Map.elems DependencyGraph
graph)
      keys :: Set PackageName
keys = DependencyGraph -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet DependencyGraph
graph
      next :: Set PackageName
next = Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set PackageName
values Set PackageName
keys
  if Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
next
    then DependencyGraph -> m DependencyGraph
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DependencyGraph
graph
    else do
      x <- (PackageName -> m (PackageName, (Set PackageName, DotPayload)))
-> [PackageName]
-> m [(PackageName, (Set PackageName, DotPayload))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
T.traverse (\PackageName
name -> (PackageName
name,) ((Set PackageName, DotPayload)
 -> (PackageName, (Set PackageName, DotPayload)))
-> m (Set PackageName, DotPayload)
-> m (PackageName, (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps PackageName
name) (Set PackageName -> [PackageName]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Set PackageName
next)
      resolveDependencies
        (subtract 1 <$> limit)
        (Map.unionWith unifier graph (Map.fromList x))
        loadPackageDeps
 where
  unifier :: (Set a, b) -> (Set a, b) -> (Set a, b)
unifier (Set a
pkgs1, b
v1) (Set a
pkgs2, b
_) = (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
pkgs1 Set a
pkgs2, b
v1)

-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in @graph@ with a

-- name in @toPrune@ and removes resulting orphans unless they are in

-- @dontPrune@

pruneGraph ::
     (F.Foldable f, F.Foldable g, Eq a)
  => f PackageName
  -> g PackageName
  -> Map PackageName (Set PackageName, a)
  -> Map PackageName (Set PackageName, a)
pruneGraph :: forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Foldable g, Eq a) =>
f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph f PackageName
dontPrune g PackageName
names =
  f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall a (f :: * -> *).
(Eq a, Foldable f) =>
f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable f PackageName
dontPrune (Map PackageName (Set PackageName, a)
 -> Map PackageName (Set PackageName, a))
-> (Map PackageName (Set PackageName, a)
    -> Map PackageName (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> (Set PackageName, a) -> Maybe (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey (\PackageName
pkg (Set PackageName
pkgDeps, a
x) ->
    if PackageName
pkg PackageName -> g PackageName -> Bool
forall a. Eq a => a -> g a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` g PackageName
names
      then Maybe (Set PackageName, a)
forall a. Maybe a
Nothing
      else let filtered :: Set PackageName
filtered = (PackageName -> Bool) -> Set PackageName -> Set PackageName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (PackageName -> g PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.notElem` g PackageName
names) Set PackageName
pkgDeps
           in  if Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
filtered Bool -> Bool -> Bool
&& Bool -> Bool
not (Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
pkgDeps)
                 then Maybe (Set PackageName, a)
forall a. Maybe a
Nothing
                 else (Set PackageName, a) -> Maybe (Set PackageName, a)
forall a. a -> Maybe a
Just (Set PackageName
filtered, a
x))

-- | Make sure that all unreachable nodes (orphans) are pruned

pruneUnreachable ::
     (Eq a, F.Foldable f)
  => f PackageName
  -> Map PackageName (Set PackageName, a)
  -> Map PackageName (Set PackageName, a)
pruneUnreachable :: forall a (f :: * -> *).
(Eq a, Foldable f) =>
f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable f PackageName
dontPrune = (Map PackageName (Set PackageName, a)
 -> Map PackageName (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall a. Eq a => (a -> a) -> a -> a
fixpoint Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
prune
 where
  fixpoint :: Eq a => (a -> a) -> a -> a
  fixpoint :: forall a. Eq a => (a -> a) -> a -> a
fixpoint a -> a
f a
v = if a -> a
f a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v then a
v else (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
fixpoint a -> a
f (a -> a
f a
v)
  prune :: Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
prune Map PackageName (Set PackageName, a)
graph' = (PackageName -> (Set PackageName, a) -> Bool)
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\PackageName
k (Set PackageName, a)
_ -> PackageName -> Bool
reachable PackageName
k) Map PackageName (Set PackageName, a)
graph'
   where
    reachable :: PackageName -> Bool
reachable PackageName
k = PackageName
k PackageName -> f PackageName -> Bool
forall a. Eq a => a -> f a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` f PackageName
dontPrune Bool -> Bool -> Bool
|| PackageName
k PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
reachables
    reachables :: Set PackageName
reachables = Map PackageName (Set PackageName) -> Set PackageName
forall m. Monoid m => Map PackageName m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ((Set PackageName, a) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, a) -> Set PackageName)
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, a)
graph')

localPackageToPackage :: LocalPackage -> Package
localPackageToPackage :: LocalPackage -> Package
localPackageToPackage LocalPackage
lp = Package -> Maybe Package -> Package
forall a. a -> Maybe a -> a
fromMaybe LocalPackage
lp.package LocalPackage
lp.testBench