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

-- | Module exporting a function to create a pruned dependency graph given a

-- '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 ( wantedToActual )
import           Stack.Types.DependencyTree ( 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.

data DependencyGraphException
  = DependencyNotFoundBug GhcPkgId
  | PackageNotFoundBug PackageName
  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, Typeable)

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."
    ]
  displayException (PackageNotFoundBug PackageName
pkgName) = String -> ShowS
bugReport String
"[S-7151]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"The '"
    , PackageName -> String
packageNameString PackageName
pkgName
    , String
"' package was not found in any of the dependency sources."
    ]

-- | 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
       (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph :: DotOpts
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts = DotOpts
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a. DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
dotOpts (RIO
   DotConfig
   (Set PackageName, Map PackageName (Set PackageName, DotPayload))
 -> RIO
      Runner
      (Set PackageName, Map PackageName (Set PackageName, DotPayload)))
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a b. (a -> b) -> a -> b
$ do
  Set PackageName
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))
  Utf8Builder -> RIO DotConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating dependency graph"
  Map PackageName (Set PackageName, DotPayload)
resultGraph <- DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph DotOpts
dotOpts
  let pkgsToPrune :: Set PackageName
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 :: Map PackageName (Set PackageName, DotPayload)
prunedGraph = Set PackageName
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
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 Map PackageName (Set PackageName, DotPayload)
resultGraph
  Utf8Builder -> RIO DotConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Returning pruned dependency graph"
  (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a. a -> RIO DotConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set PackageName
localNames, Map PackageName (Set PackageName, DotPayload)
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
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
    Map PackageName Version
globals <- WantedCompiler -> RIO BuildConfig (Map PackageName Version)
forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints BuildConfig
buildConfig.smWanted.compiler
    GhcPkgId
fakeGhcPkgId <- Text -> RIO BuildConfig GhcPkgId
forall (m :: * -> *). MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId Text
"ignored"
    ActualCompiler
actual <- (CompilerException -> RIO BuildConfig ActualCompiler)
-> (ActualCompiler -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO BuildConfig ActualCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActualCompiler -> RIO BuildConfig ActualCompiler
forall a. a -> RIO BuildConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CompilerException ActualCompiler
 -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a b. (a -> b) -> a -> b
$
      WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual BuildConfig
buildConfig.smWanted.compiler
    let smActual :: SMActual DumpPackage
smActual = SMActual
          { $sel:compiler:SMActual :: ActualCompiler
compiler = ActualCompiler
actual
          , $sel:project:SMActual :: Map PackageName ProjectPackage
project = BuildConfig
buildConfig.smWanted.project
          , $sel:deps:SMActual :: Map PackageName DepPackage
deps =  BuildConfig
buildConfig.smWanted.deps
          , $sel:globals:SMActual :: 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 -> Version -> DumpPackage
toDump PackageName
name Version
version = DumpPackage
          { $sel:ghcPkgId:DumpPackage :: GhcPkgId
ghcPkgId = GhcPkgId
fakeGhcPkgId
          , $sel:packageIdent:DumpPackage :: PackageIdentifier
packageIdent = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
          , $sel:sublib:DumpPackage :: Maybe SublibDump
sublib = Maybe SublibDump
forall a. Maybe a
Nothing
          , $sel:license:DumpPackage :: Maybe License
license = Maybe License
forall a. Maybe a
Nothing
          , $sel:libDirs:DumpPackage :: [String]
libDirs = []
          , $sel:libraries:DumpPackage :: [Text]
libraries = []
          , $sel:hasExposedModules:DumpPackage :: Bool
hasExposedModules = Bool
True
          , $sel:exposedModules:DumpPackage :: Set ModuleName
exposedModules = Set ModuleName
forall a. Monoid a => a
mempty
          , $sel:depends:DumpPackage :: [GhcPkgId]
depends = []
          , $sel:haddockInterfaces:DumpPackage :: [String]
haddockInterfaces = []
          , $sel:haddockHtml:DumpPackage :: Maybe String
haddockHtml = Maybe String
forall a. Maybe a
Nothing
          , $sel:isExposed:DumpPackage :: Bool
isExposed = Bool
True
          }
        actualPkgs :: Set PackageName
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 GlobalPackage
prunedActual = SMActual DumpPackage
smActual
          { globals = pruneGlobals smActual.globals actualPkgs }
    SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO BuildConfig SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
NeedTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
    Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loading source map"
    SourceMap
sourceMap <- SMTargets
-> BuildOptsCLI
-> SMActual DumpPackage
-> RIO BuildConfig SourceMap
forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI -> SMActual DumpPackage -> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpPackage
smActual
    let dc :: DotConfig
dc = DotConfig
                { BuildConfig
buildConfig :: BuildConfig
$sel:buildConfig:DotConfig :: BuildConfig
buildConfig
                , SourceMap
sourceMap :: SourceMap
$sel:sourceMap:DotConfig :: SourceMap
sourceMap
                , $sel:globalDump:DotConfig :: [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
                }
    Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"DotConfig fully loaded"
    DotConfig -> RIO DotConfig a -> RIO BuildConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO DotConfig
dc RIO DotConfig a
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
envConfig <- RIO EnvConfig EnvConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    let sourceMap :: SourceMap
sourceMap = EnvConfig
envConfig.sourceMap
    InstallMap
installMap <- SourceMap -> RIO EnvConfig InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    (InstalledMap
_, [DumpPackage]
globalDump, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
     EnvConfig
     (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
    let dc :: DotConfig
dc = DotConfig
          { $sel:buildConfig:DotConfig :: BuildConfig
buildConfig = EnvConfig
envConfig.buildConfig
          , SourceMap
$sel:sourceMap:DotConfig :: SourceMap
sourceMap :: SourceMap
sourceMap
          , [DumpPackage]
$sel:globalDump:DotConfig :: [DumpPackage]
globalDump :: [DumpPackage]
globalDump
          }
    DotConfig -> RIO DotConfig a -> RIO EnvConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO DotConfig
dc RIO DotConfig a
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 (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph :: DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph DotOpts
dotOpts = do
  SourceMap
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
  [LocalPackage]
locals <- [ProjectPackage]
-> (ProjectPackage -> RIO DotConfig LocalPackage)
-> RIO DotConfig [LocalPackage]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName ProjectPackage -> [ProjectPackage]
forall a. Map PackageName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SourceMap
sourceMap.project) ProjectPackage -> RIO DotConfig LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage
  let graph :: Map PackageName (Set PackageName, DotPayload)
graph =
        [(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, (Set PackageName, DotPayload))]
 -> Map PackageName (Set PackageName, DotPayload))
-> [(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
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)
  [DumpPackage]
globalDump <- Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [DumpPackage] DotConfig [DumpPackage]
 -> RIO DotConfig [DumpPackage])
-> Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage]
forall a b. (a -> b) -> a -> b
$ (DotConfig -> [DumpPackage])
-> SimpleGetter DotConfig [DumpPackage]
forall s a. (s -> a) -> SimpleGetter s a
to (.globalDump)
  -- TODO: Can there be multiple entries for wired-in-packages? If so,

  -- this will choose one arbitrarily..

  let globalDumpMap :: Map PackageName DumpPackage
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 :: Map GhcPkgId PackageIdentifier
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 :: PackageName -> RIO DotConfig (Set PackageName, DotPayload)
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
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO env (Set PackageName, DotPayload)
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
                 , Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version) (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) 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)
  Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies DotOpts
dotOpts.dependencyDepth Map PackageName (Set PackageName, DotPayload)
graph PackageName -> RIO DotConfig (Set PackageName, DotPayload)
depLoader
 where
  makePayload :: PackageLocationImmutable -> r -> DotPayload
makePayload PackageLocationImmutable
loc r
pkg = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just r
pkg.version)
                                   (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just r
pkg.license)
                                   (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
$ RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
"N/A") Path Abs Dir
pkgDir
              in  (Package
pkg.name, (Package -> Set PackageName -> Set PackageName
forall {r}.
HasField "name" r PackageName =>
r -> 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 :: r -> Set PackageName -> Set PackageName
deps r
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 r
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 =
    Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just r
pkg.version)
               (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just r
pkg.license)
               (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 (DependencyGraphException
-> RIO DotConfig (Set PackageName, DotPayload)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DependencyGraphException
 -> RIO DotConfig (Set PackageName, DotPayload))
-> DependencyGraphException
-> RIO DotConfig (Set PackageName, DotPayload)
forall a b. (a -> b) -> a -> b
$ PackageName -> DependencyGraphException
PackageNotFoundBug 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
      Package
pkg <- CommonPackage -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage r
pp.projectCommon
      (Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Set PackageName
setOfPackageDeps Package
pkg, Package -> Maybe PackageLocation -> DotPayload
forall {r}.
(HasField "version" r Version,
 HasField "license" r (Either License License)) =>
r -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg Maybe PackageLocation
forall a. Maybe a
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{ $sel:location:DepPackage :: DepPackage -> PackageLocation
location = PLMutable ResolvedPath Dir
dir } = do
      ProjectPackage
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
      Package
pkg <- CommonPackage -> RIO DotConfig Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage ProjectPackage
pp.projectCommon
      (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. a -> RIO DotConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Set PackageName
setOfPackageDeps Package
pkg, Package -> Maybe PackageLocation -> DotPayload
forall {r}.
(HasField "version" r Version,
 HasField "license" r (Either License License)) =>
r -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just (PackageLocation -> Maybe PackageLocation)
-> PackageLocation -> Maybe PackageLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> PackageLocation
PLMutable ResolvedPath Dir
dir))

    loadDeps dp :: DepPackage
dp@DepPackage{ $sel:location:DepPackage :: DepPackage -> PackageLocation
location = PLImmutable PackageLocationImmutable
loc } = do
      let common :: CommonPackage
common = DepPackage
dp.depCommon
      GenericPackageDescription
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 PackageName
name Version
version = PackageDescription -> PackageIdentifier
PD.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd
          flags :: Map FlagName Bool
flags = CommonPackage
common.flags
          ghcOptions :: [Text]
ghcOptions = CommonPackage
common.ghcOptions
          cabalConfigOpts :: [Text]
cabalConfigOpts = CommonPackage
common.cabalConfigOpts
      Bool
-> RIO DotConfig (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. HasCallStack => Bool -> a -> a
assert
        (PackageName
pkgName PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name)
        (PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
loadPackageDeps PackageName
pkgName Version
version PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
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)
forall {r}.
(HasField "license" r (Maybe License),
 HasField "depends" r [GhcPkgId],
 HasField "packageIdent" r PackageIdentifier) =>
r -> (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 :: r -> (Set PackageName, DotPayload)
getDepsFromDump r
dump = ([PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList [PackageName]
deps, r -> DotPayload
forall {r}.
(HasField "license" r (Maybe License),
 HasField "packageIdent" r PackageIdentifier) =>
r -> DotPayload
payloadFromDump r
dump)
     where
      deps :: [PackageName]
deps = (GhcPkgId -> PackageName) -> [GhcPkgId] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map GhcPkgId -> PackageName
ghcIdToPackageName r
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 Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just r
pkg.version) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just r
pkg.license)

  payloadFromDump :: r -> DotPayload
payloadFromDump r
dp =
    Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (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 -> 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)
               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
  -> Map PackageName (Set PackageName, DotPayload)
  -> (PackageName -> m (Set PackageName, DotPayload))
  -> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies :: forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (Just Int
0) Map PackageName (Set PackageName, DotPayload)
graph PackageName -> m (Set PackageName, DotPayload)
_ = Map PackageName (Set PackageName, DotPayload)
-> m (Map PackageName (Set PackageName, DotPayload))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName (Set PackageName, DotPayload)
graph
resolveDependencies Maybe Int
limit Map PackageName (Set PackageName, DotPayload)
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
<$> Map PackageName (Set PackageName, DotPayload)
-> [(Set PackageName, DotPayload)]
forall k a. Map k a -> [a]
Map.elems Map PackageName (Set PackageName, DotPayload)
graph)
      keys :: Set PackageName
keys = Map PackageName (Set PackageName, DotPayload) -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName (Set PackageName, DotPayload)
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 Map PackageName (Set PackageName, DotPayload)
-> m (Map PackageName (Set PackageName, DotPayload))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName (Set PackageName, DotPayload)
graph
     else do
       [(PackageName, (Set PackageName, DotPayload))]
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)
       Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
limit)
                      (((Set PackageName, DotPayload)
 -> (Set PackageName, DotPayload) -> (Set PackageName, DotPayload))
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Set PackageName, DotPayload)
-> (Set PackageName, DotPayload) -> (Set PackageName, DotPayload)
forall {a} {b} {b}. Ord a => (Set a, b) -> (Set a, b) -> (Set a, b)
unifier Map PackageName (Set PackageName, DotPayload)
graph ([(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, (Set PackageName, DotPayload))]
x))
                      PackageName -> m (Set PackageName, DotPayload)
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)
forall {b}.
Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
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, b)
-> Map PackageName (Set PackageName, b)
prune Map PackageName (Set PackageName, b)
graph' = (PackageName -> (Set PackageName, b) -> Bool)
-> Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\PackageName
k (Set PackageName, b)
_ -> PackageName -> Bool
reachable PackageName
k) Map PackageName (Set PackageName, b)
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, b) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, b) -> Set PackageName)
-> Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, b)
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