{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
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 (..)
)
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."
]
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)
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)
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)
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
| 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)
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)
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)
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
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 ::
(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))
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