{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Stack.Build.ConstructPlan
( constructPlan
) where
import Stack.Prelude hiding (Display (..), loadPackage)
import Control.Monad.RWS.Strict hiding ((<>))
import Control.Monad.State.Strict (execState)
import Data.List
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import Data.Monoid.Map (MonoidMap(..))
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Distribution.Text as Cabal
import qualified Distribution.Version as Cabal
import Distribution.Types.BuildType (BuildType (Configure))
import Distribution.Types.PackageName (mkPackageName)
import Distribution.Version (mkVersion)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Path (parent)
import qualified RIO
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Constants
import Stack.Package
import Stack.PackageDump
import Stack.SourceMap
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.SourceMap
import Stack.Types.Version
import System.Environment (lookupEnv)
import System.IO (putStrLn)
import RIO.PrettyPrint
import RIO.Process (findExecutable, HasProcessContext (..))
data PackageInfo
=
PIOnlyInstalled InstallLocation Installed
| PIOnlySource PackageSource
| PIBoth PackageSource Installed
deriving (Int -> PackageInfo -> ShowS
[PackageInfo] -> ShowS
PackageInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageInfo] -> ShowS
$cshowList :: [PackageInfo] -> ShowS
show :: PackageInfo -> [Char]
$cshow :: PackageInfo -> [Char]
showsPrec :: Int -> PackageInfo -> ShowS
$cshowsPrec :: Int -> PackageInfo -> ShowS
Show)
combineSourceInstalled :: PackageSource
-> (InstallLocation, Installed)
-> PackageInfo
combineSourceInstalled :: PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
ps (InstallLocation
location, Installed
installed) =
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageSource -> Version
psVersion PackageSource
ps forall a. Eq a => a -> a -> Bool
== Installed -> Version
installedVersion Installed
installed) forall a b. (a -> b) -> a -> b
$
case InstallLocation
location of
InstallLocation
Snap -> InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled InstallLocation
location Installed
installed
InstallLocation
Local -> PackageSource -> Installed -> PackageInfo
PIBoth PackageSource
ps Installed
installed
type CombinedMap = Map PackageName PackageInfo
combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap = forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
(\PackageName
_ PackageSource
s (InstallLocation, Installed)
i -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSource -> PackageInfo
PIOnlySource)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled))
data AddDepRes
= ADRToInstall Task
| ADRFound InstallLocation Installed
deriving Int -> AddDepRes -> ShowS
[AddDepRes] -> ShowS
AddDepRes -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AddDepRes] -> ShowS
$cshowList :: [AddDepRes] -> ShowS
show :: AddDepRes -> [Char]
$cshow :: AddDepRes -> [Char]
showsPrec :: Int -> AddDepRes -> ShowS
$cshowsPrec :: Int -> AddDepRes -> ShowS
Show
type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])
data W = W
{ W -> Map PackageName (Either ConstructPlanException Task)
wFinals :: !(Map PackageName (Either ConstructPlanException Task))
, W -> Map Text InstallLocation
wInstall :: !(Map Text InstallLocation)
, W -> Map PackageName Text
wDirty :: !(Map PackageName Text)
, W -> [Text] -> [Text]
wWarnings :: !([Text] -> [Text])
, W -> ParentMap
wParents :: !ParentMap
} deriving forall x. Rep W x -> W
forall x. W -> Rep W x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep W x -> W
$cfrom :: forall x. W -> Rep W x
Generic
instance Semigroup W where
<> :: W -> W -> W
(<>) = forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault
instance Monoid W where
mempty :: W
mempty = forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
mappend :: W -> W -> W
mappend = forall a. Semigroup a => a -> a -> a
(<>)
type M = RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
data Ctx = Ctx
{ Ctx -> BaseConfigOpts
baseConfigOpts :: !BaseConfigOpts
, Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage :: !(PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> M Package)
, Ctx -> CombinedMap
combinedMap :: !CombinedMap
, Ctx -> EnvConfig
ctxEnvConfig :: !EnvConfig
, Ctx -> [PackageName]
callStack :: ![PackageName]
, Ctx -> Set PackageName
wanted :: !(Set PackageName)
, Ctx -> Set PackageName
localNames :: !(Set PackageName)
, Ctx -> Maybe Curator
mcurator :: !(Maybe Curator)
, Ctx -> Text
pathEnvVar :: !Text
}
instance HasPlatform Ctx
instance HasGHCVariant Ctx
instance HasLogFunc Ctx where
logFuncL :: Lens' Ctx LogFunc
logFuncL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasRunner Ctx where
runnerL :: Lens' Ctx Runner
runnerL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasRunner env => Lens' env Runner
runnerL
instance HasStylesUpdate Ctx where
stylesUpdateL :: Lens' Ctx StylesUpdate
stylesUpdateL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasTerm Ctx where
useColorL :: Lens' Ctx Bool
useColorL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Bool
useColorL
termWidthL :: Lens' Ctx Int
termWidthL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Int
termWidthL
instance HasConfig Ctx
instance HasPantryConfig Ctx where
pantryConfigL :: Lens' Ctx PantryConfig
pantryConfigL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasProcessContext Ctx where
processContextL :: Lens' Ctx ProcessContext
processContextL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasBuildConfig Ctx
instance HasSourceMap Ctx where
sourceMapL :: Lens' Ctx SourceMap
sourceMapL = forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasSourceMap env => Lens' env SourceMap
sourceMapL
instance HasCompiler Ctx where
compilerPathsL :: SimpleGetter Ctx CompilerPaths
compilerPathsL = forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsL
instance HasEnvConfig Ctx where
envConfigL :: Lens' Ctx EnvConfig
envConfigL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Ctx -> EnvConfig
ctxEnvConfig (\Ctx
x EnvConfig
y -> Ctx
x { ctxEnvConfig :: EnvConfig
ctxEnvConfig = EnvConfig
y })
constructPlan :: forall env. HasEnvConfig env
=> BaseConfigOpts
-> [DumpPackage]
-> (PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package)
-> SourceMap
-> InstalledMap
-> Bool
-> RIO env Plan
constructPlan :: forall env.
HasEnvConfig env =>
BaseConfigOpts
-> [DumpPackage]
-> (PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package)
-> SourceMap
-> InstalledMap
-> Bool
-> RIO env Plan
constructPlan BaseConfigOpts
baseConfigOpts0 [DumpPackage]
localDumpPkgs PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
loadPackage0 SourceMap
sourceMap InstalledMap
installedMap Bool
initialBuildSteps = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Constructing the build plan"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasBaseInDeps forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"You are trying to upgrade/downgrade base, which is almost certainly not what you really want. Please, consider using another GHC version if you need a certain version of base, or removing base from extra-deps. See more at https://github.com/commercialhaskell/stack/issues/3940." forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
EnvConfig
econfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
Version
globalCabalVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Version
cpCabalVersion
Map PackageName PackageSource
sources <- forall {s}.
(HasBuildConfig s, HasSourceMap s) =>
Version -> RIO s (Map PackageName PackageSource)
getSources Version
globalCabalVersion
Maybe Curator
mcur <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
let onTarget :: PackageName
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
onTarget = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> M (Either ConstructPlanException AddDepRes)
addDep
let inner :: RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
inner = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
onTarget forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (SMTargets -> Map PackageName Target
smtTargets forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
Text
pathEnvVar' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PATH"
let ctx :: Ctx
ctx = EnvConfig
-> Version
-> Map PackageName PackageSource
-> Maybe Curator
-> Text
-> Ctx
mkCtx EnvConfig
econfig Version
globalCabalVersion Map PackageName PackageSource
sources Maybe Curator
mcur Text
pathEnvVar'
((), Map PackageName (Either ConstructPlanException AddDepRes)
m, W Map PackageName (Either ConstructPlanException Task)
efinals Map Text InstallLocation
installExes Map PackageName Text
dirtyReason [Text] -> [Text]
warnings ParentMap
parents) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
inner Ctx
ctx forall k a. Map k a
M.empty
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
RIO.display) ([Text] -> [Text]
warnings [])
let toEither :: (a, Either a b) -> Either a (a, b)
toEither (a
_, Left a
e) = forall a b. a -> Either a b
Left a
e
toEither (a
k, Right b
v) = forall a b. b -> Either a b
Right (a
k, b
v)
([ConstructPlanException]
errlibs, [(PackageName, AddDepRes)]
adrs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {b}. (a, Either a b) -> Either a (a, b)
toEither forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map PackageName (Either ConstructPlanException AddDepRes)
m
([ConstructPlanException]
errfinals, [(PackageName, Task)]
finals) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {b}. (a, Either a b) -> Either a (a, b)
toEither forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map PackageName (Either ConstructPlanException Task)
efinals
errs :: [ConstructPlanException]
errs = [ConstructPlanException]
errlibs forall a. [a] -> [a] -> [a]
++ [ConstructPlanException]
errfinals
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructPlanException]
errs
then do
let toTask :: (a, AddDepRes) -> Maybe (a, Task)
toTask (a
_, ADRFound InstallLocation
_ Installed
_) = forall a. Maybe a
Nothing
toTask (a
name, ADRToInstall Task
task) = forall a. a -> Maybe a
Just (a
name, Task
task)
tasks :: Map PackageName Task
tasks = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, AddDepRes) -> Maybe (a, Task)
toTask [(PackageName, AddDepRes)]
adrs
takeSubset :: Plan -> RIO env Plan
takeSubset =
case BuildOptsCLI -> BuildSubset
boptsCLIBuildSubset forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI BaseConfigOpts
baseConfigOpts0 of
BuildSubset
BSAll -> forall (f :: * -> *) a. Applicative f => a -> f a
pure
BuildSubset
BSOnlySnapshot -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plan -> Plan
stripLocals
BuildSubset
BSOnlyDependencies -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PackageName -> Plan -> Plan
stripNonDeps (forall k a. Map k a -> Set k
M.keysSet forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
BuildSubset
BSOnlyLocals -> forall env. Plan -> RIO env Plan
errorOnSnapshot
forall env. Plan -> RIO env Plan
takeSubset Plan
{ planTasks :: Map PackageName Task
planTasks = Map PackageName Task
tasks
, planFinals :: Map PackageName Task
planFinals = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(PackageName, Task)]
finals
, planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal = Map PackageName Task
-> Map PackageName Text
-> [DumpPackage]
-> Bool
-> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal Map PackageName Task
tasks Map PackageName Text
dirtyReason [DumpPackage]
localDumpPkgs Bool
initialBuildSteps
, planInstallExes :: Map Text InstallLocation
planInstallExes =
if BuildOpts -> Bool
boptsInstallExes (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
baseConfigOpts0) Bool -> Bool -> Bool
||
BuildOpts -> Bool
boptsInstallCompilerTool (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
baseConfigOpts0)
then Map Text InstallLocation
installExes
else forall k a. Map k a
Map.empty
}
else do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show [ConstructPlanException]
errs
Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
Path Abs Dir
stackRoot <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyErrorNoIndent forall a b. (a -> b) -> a -> b
$
[ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parents (Ctx -> Set PackageName
wanted Ctx
ctx) Map PackageName [PackageName]
prunedGlobalDeps
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> StackBuildException
ConstructPlanFailed [Char]
"Plan construction failed."
where
hasBaseInDeps :: Bool
hasBaseInDeps = forall k a. Ord k => k -> Map k a -> Bool
Map.member ([Char] -> PackageName
mkPackageName [Char]
"base") (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
mkCtx :: EnvConfig
-> Version
-> Map PackageName PackageSource
-> Maybe Curator
-> Text
-> Ctx
mkCtx EnvConfig
econfig Version
globalCabalVersion Map PackageName PackageSource
sources Maybe Curator
mcur Text
pathEnvVar' = Ctx
{ baseConfigOpts :: BaseConfigOpts
baseConfigOpts = BaseConfigOpts
baseConfigOpts0
, loadPackage :: PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> M Package
loadPackage = \PackageLocationImmutable
w Map FlagName Bool
x [Text]
y [Text]
z -> forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
econfig forall a b. (a -> b) -> a -> b
$
Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
loadPackage0 PackageLocationImmutable
w Map FlagName Bool
x [Text]
y [Text]
z
, combinedMap :: CombinedMap
combinedMap = Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap Map PackageName PackageSource
sources InstalledMap
installedMap
, ctxEnvConfig :: EnvConfig
ctxEnvConfig = EnvConfig
econfig
, callStack :: [PackageName]
callStack = []
, wanted :: Set PackageName
wanted = forall k a. Map k a -> Set k
Map.keysSet (SMTargets -> Map PackageName Target
smtTargets forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
, localNames :: Set PackageName
localNames = forall k a. Map k a -> Set k
Map.keysSet (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap)
, mcurator :: Maybe Curator
mcurator = Maybe Curator
mcur
, pathEnvVar :: Text
pathEnvVar = Text
pathEnvVar'
}
prunedGlobalDeps :: Map PackageName [PackageName]
prunedGlobalDeps = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \GlobalPackage
gp ->
case GlobalPackage
gp of
ReplacedGlobalPackage [PackageName]
deps ->
let pruned :: [PackageName]
pruned = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
inSourceMap) [PackageName]
deps
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
pruned then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [PackageName]
pruned
GlobalPackage Version
_ -> forall a. Maybe a
Nothing
inSourceMap :: PackageName -> Bool
inSourceMap PackageName
pname = PackageName
pname forall k a. Ord k => k -> Map k a -> Bool
`Map.member` SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap Bool -> Bool -> Bool
||
PackageName
pname forall k a. Ord k => k -> Map k a -> Bool
`Map.member` SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap
getSources :: Version -> RIO s (Map PackageName PackageSource)
getSources Version
globalCabalVersion = do
let loadLocalPackage' :: ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp = do
LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage ProjectPackage
pp
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp }
Map PackageName PackageSource
pPackages <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> BuildOpts
configBuild
Map PackageName PackageSource
deps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
PLImmutable PackageLocationImmutable
loc ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable
-> Version -> FromSnapshot -> CommonPackage -> PackageSource
PSRemote PackageLocationImmutable
loc (PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
loc) (DepPackage -> FromSnapshot
dpFromSnapshot DepPackage
dp) (DepPackage -> CommonPackage
dpCommon DepPackage
dp)
PLMutable ResolvedPath Dir
dir -> do
ProjectPackage
pp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
dir (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)
LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map PackageName PackageSource
pPackages forall a. Semigroup a => a -> a -> a
<> Map PackageName PackageSource
deps
errorOnSnapshot :: Plan -> RIO env Plan
errorOnSnapshot :: forall env. Plan -> RIO env Plan
errorOnSnapshot plan :: Plan
plan@(Plan Map PackageName Task
tasks Map PackageName Task
_finals Map GhcPkgId (PackageIdentifier, Text)
_unregister Map Text InstallLocation
installExes) = do
let snapTasks :: [PackageName]
snapTasks = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Task
t -> Task -> InstallLocation
taskLocation Task
t forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) Map PackageName Task
tasks
let snapExes :: [Text]
snapExes = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) Map Text InstallLocation
installExes
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
snapTasks Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
snapExes) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
[PackageName] -> [Text] -> NotOnlyLocal
NotOnlyLocal [PackageName]
snapTasks [Text]
snapExes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Plan
plan
data NotOnlyLocal = NotOnlyLocal [PackageName] [Text]
instance Show NotOnlyLocal where
show :: NotOnlyLocal -> [Char]
show (NotOnlyLocal [PackageName]
packages [Text]
exes) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Specified only-locals, but I need to build snapshot contents:\n"
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
packages then [Char]
"" else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Packages: "
, forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString [PackageName]
packages)
, [Char]
"\n"
]
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
exes then [Char]
"" else forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Executables: "
, forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
exes)
, [Char]
"\n"
]
]
instance Exception NotOnlyLocal
data UnregisterState = UnregisterState
{ UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text))
, UnregisterState -> [DumpPackage]
usKeep :: ![DumpPackage]
, UnregisterState -> Bool
usAnyAdded :: !Bool
}
mkUnregisterLocal :: Map PackageName Task
-> Map PackageName Text
-> [DumpPackage]
-> Bool
-> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal :: Map PackageName Task
-> Map PackageName Text
-> [DumpPackage]
-> Bool
-> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal Map PackageName Task
tasks Map PackageName Text
dirtyReason [DumpPackage]
localDumpPkgs Bool
initialBuildSteps =
Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop forall k a. Map k a
Map.empty [DumpPackage]
localDumpPkgs
where
loop :: Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop Map GhcPkgId (PackageIdentifier, Text)
toUnregister [DumpPackage]
keep
| UnregisterState -> Bool
usAnyAdded UnregisterState
us = Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) (UnregisterState -> [DumpPackage]
usKeep UnregisterState
us)
| Bool
otherwise = UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us
where
us :: UnregisterState
us = forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
MonadState UnregisterState m =>
DumpPackage -> m ()
go [DumpPackage]
keep) UnregisterState
{ usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = Map GhcPkgId (PackageIdentifier, Text)
toUnregister
, usKeep :: [DumpPackage]
usKeep = []
, usAnyAdded :: Bool
usAnyAdded = Bool
False
}
go :: DumpPackage -> m ()
go DumpPackage
dp = do
UnregisterState
us <- forall s (m :: * -> *). MonadState s m => m s
get
case forall {a} {b}.
Ord a =>
Map a (PackageIdentifier, b)
-> PackageIdentifier -> [a] -> Maybe Text
go' (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) PackageIdentifier
ident [GhcPkgId]
deps of
Maybe Text
Nothing -> forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us { usKeep :: [DumpPackage]
usKeep = DumpPackage
dp forall a. a -> [a] -> [a]
: UnregisterState -> [DumpPackage]
usKeep UnregisterState
us }
Just Text
reason -> forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us
{ usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert GhcPkgId
gid (PackageIdentifier
ident, Text
reason) (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us)
, usAnyAdded :: Bool
usAnyAdded = Bool
True
}
where
gid :: GhcPkgId
gid = DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp
ident :: PackageIdentifier
ident = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
deps :: [GhcPkgId]
deps = DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp
go' :: Map a (PackageIdentifier, b)
-> PackageIdentifier -> [a] -> Maybe Text
go' Map a (PackageIdentifier, b)
toUnregister PackageIdentifier
ident [a]
deps
| Just Task
task <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Task
tasks
= if Bool
initialBuildSteps Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task Bool -> Bool -> Bool
&& Task -> PackageIdentifier
taskProvides Task
task forall a. Eq a => a -> a -> Bool
== PackageIdentifier
ident
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Text
dirtyReason
| (PackageIdentifier
dep, b
_):[(PackageIdentifier, b)]
_ <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a (PackageIdentifier, b)
toUnregister) [a]
deps
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"Dependency being unregistered: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
dep)
| Bool
otherwise = forall a. Maybe a
Nothing
where
name :: PackageName
name :: PackageName
name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident
addFinal :: LocalPackage -> Package -> Bool -> Bool -> M ()
addFinal :: LocalPackage
-> Package
-> Bool
-> Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
addFinal LocalPackage
lp Package
package Bool
isAllInOne Bool
buildHaddocks = do
Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
depsRes <- Package
-> M (Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package
Either ConstructPlanException Task
res <- case Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
depsRes of
Left ConstructPlanException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ConstructPlanException
e
Right (Set PackageIdentifier
missing, Map PackageIdentifier GhcPkgId
present, IsMutable
_minLoc) -> do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Task
{ taskProvides :: PackageIdentifier
taskProvides = PackageName -> Version -> PackageIdentifier
PackageIdentifier
(Package -> PackageName
packageName Package
package)
(Package -> Version
packageVersion Package
package)
, taskConfigOpts :: TaskConfigOpts
taskConfigOpts = Set PackageIdentifier
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
TaskConfigOpts Set PackageIdentifier
missing forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
present Map PackageIdentifier GhcPkgId
missing'
in EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
(Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
Map PackageIdentifier GhcPkgId
allDeps
Bool
True
IsMutable
Mutable
Package
package
, taskBuildHaddock :: Bool
taskBuildHaddock = Bool
buildHaddocks
, taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = Map PackageIdentifier GhcPkgId
present
, taskType :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
, taskAllInOne :: Bool
taskAllInOne = Bool
isAllInOne
, taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = [Char] -> CachePkgSrc
CacheSrcLocal (forall b t. Path b t -> [Char]
toFilePath (forall b t. Path b t -> Path b Dir
parent (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)))
, taskAnyMissing :: Bool
taskAnyMissing = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
, taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
}
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wFinals :: Map PackageName (Either ConstructPlanException Task)
wFinals = forall k a. k -> a -> Map k a
Map.singleton (Package -> PackageName
packageName Package
package) Either ConstructPlanException Task
res }
addDep :: PackageName
-> M (Either ConstructPlanException AddDepRes)
addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)
addDep PackageName
name = do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
Map PackageName (Either ConstructPlanException AddDepRes)
m <- forall s (m :: * -> *). MonadState s m => m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
m of
Just Either ConstructPlanException AddDepRes
res -> do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Using cached result for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Either ConstructPlanException AddDepRes
res
forall (m :: * -> *) a. Monad m => a -> m a
return Either ConstructPlanException AddDepRes
res
Maybe (Either ConstructPlanException AddDepRes)
Nothing -> do
Either ConstructPlanException AddDepRes
res <- if PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Ctx -> [PackageName]
callStack Ctx
ctx
then do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Detected cycle " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Ctx -> [PackageName]
callStack Ctx
ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [PackageName] -> ConstructPlanException
DependencyCycleDetected forall a b. (a -> b) -> a -> b
$ PackageName
name forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx
else forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Ctx
ctx' -> Ctx
ctx' { callStack :: [PackageName]
callStack = PackageName
name forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx' }) forall a b. (a -> b) -> a -> b
$ do
let mpackageInfo :: Maybe PackageInfo
mpackageInfo = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name forall a b. (a -> b) -> a -> b
$ Ctx -> CombinedMap
combinedMap Ctx
ctx
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Package info for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Maybe PackageInfo
mpackageInfo
case Maybe PackageInfo
mpackageInfo of
Maybe PackageInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PackageName -> ConstructPlanException
UnknownPackage PackageName
name
Just (PIOnlyInstalled InstallLocation
loc Installed
installed) -> do
let version :: Version
version = Installed -> Version
installedVersion Installed
installed
askPkgLoc :: RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
askPkgLoc = forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m) =>
RIO env a -> m a
liftRIO forall a b. (a -> b) -> a -> b
$ do
Maybe (Revision, BlobKey, TreeKey)
mrev <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
case Maybe (Revision, BlobKey, TreeKey)
mrev of
Maybe (Revision, BlobKey, TreeKey)
Nothing -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No latest package revision found for: " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", dependency callstack: " forall a. Semigroup a => a -> a -> a
<>
forall a. Show a => a -> Utf8Builder
displayShow (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Ctx -> [PackageName]
callStack Ctx
ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
PackageName
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutablesUpstream PackageName
name RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
askPkgLoc InstallLocation
loc forall k a. Map k a
Map.empty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
Just (PIOnlySource PackageSource
ps) -> do
PackageName
-> PackageSource
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutables PackageName
name PackageSource
ps
PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps forall a. Maybe a
Nothing
Just (PIBoth PackageSource
ps Installed
installed) -> do
PackageName
-> PackageSource
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutables PackageName
name PackageSource
ps
PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps (forall a. a -> Maybe a
Just Installed
installed)
PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
forall (m :: * -> *) a. Monad m => a -> m a
return Either ConstructPlanException AddDepRes
res
tellExecutables :: PackageName -> PackageSource -> M ()
tellExecutables :: PackageName
-> PackageSource
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutables PackageName
_name (PSFilePath LocalPackage
lp)
| LocalPackage -> Bool
lpWanted LocalPackage
lp = InstallLocation
-> Package
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutablesPackage InstallLocation
Local forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
tellExecutables PackageName
name (PSRemote PackageLocationImmutable
pkgloc Version
_version FromSnapshot
_fromSnapshot CommonPackage
cp) =
PackageName
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutablesUpstream PackageName
name (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just PackageLocationImmutable
pkgloc) InstallLocation
Snap (CommonPackage -> Map FlagName Bool
cpFlags CommonPackage
cp)
tellExecutablesUpstream ::
PackageName
-> M (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> M ()
tellExecutablesUpstream :: PackageName
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutablesUpstream PackageName
name RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
retrievePkgLoc InstallLocation
loc Map FlagName Bool
flags = do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Ctx -> Set PackageName
wanted Ctx
ctx) forall a b. (a -> b) -> a -> b
$ do
Maybe PackageLocationImmutable
mPkgLoc <- RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
(Maybe PackageLocationImmutable)
retrievePkgLoc
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PackageLocationImmutable
mPkgLoc forall a b. (a -> b) -> a -> b
$ \PackageLocationImmutable
pkgLoc -> do
Package
p <- Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage Ctx
ctx PackageLocationImmutable
pkgLoc Map FlagName Bool
flags [] []
InstallLocation
-> Package
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutablesPackage InstallLocation
loc Package
p
tellExecutablesPackage :: InstallLocation -> Package -> M ()
tellExecutablesPackage :: InstallLocation
-> Package
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
tellExecutablesPackage InstallLocation
loc Package
p = do
CombinedMap
cm <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> CombinedMap
combinedMap
let myComps :: Set Text
myComps =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Package -> PackageName
packageName Package
p) CombinedMap
cm of
Maybe PackageInfo
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a. Set a
Set.empty
Just (PIOnlyInstalled InstallLocation
_ Installed
_) -> forall a. Set a
Set.empty
Just (PIOnlySource PackageSource
ps) -> PackageSource -> Set Text
goSource PackageSource
ps
Just (PIBoth PackageSource
ps Installed
_) -> PackageSource -> Set Text
goSource PackageSource
ps
goSource :: PackageSource -> Set Text
goSource (PSFilePath LocalPackage
lp)
| LocalPackage -> Bool
lpWanted LocalPackage
lp = Set NamedComponent -> Set Text
exeComponents (LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)
| Bool
otherwise = forall a. Set a
Set.empty
goSource PSRemote{} = forall a. Set a
Set.empty
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wInstall :: Map Text InstallLocation
wInstall = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (, InstallLocation
loc) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall {a}. Ord a => Set a -> Set a -> Set a
filterComps Set Text
myComps forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageExes Package
p }
where
filterComps :: Set a -> Set a -> Set a
filterComps Set a
myComps Set a
x
| forall a. Set a -> Bool
Set.null Set a
myComps = Set a
x
| Bool
otherwise = forall {a}. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
x Set a
myComps
installPackage :: PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage :: PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
minstalled = do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
case PackageSource
ps of
PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
cp -> do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: Doing all-in-one build for upstream package " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name
Package
package <- Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage Ctx
ctx PackageLocationImmutable
pkgLoc (CommonPackage -> Map FlagName Bool
cpFlags CommonPackage
cp) (CommonPackage -> [Text]
cpGhcOptions CommonPackage
cp) (CommonPackage -> [Text]
cpCabalConfigOpts CommonPackage
cp)
Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
True (CommonPackage -> Bool
cpHaddocks CommonPackage
cp) PackageSource
ps Package
package Maybe Installed
minstalled
PSFilePath LocalPackage
lp -> do
case LocalPackage -> Maybe Package
lpTestBench LocalPackage
lp of
Maybe Package
Nothing -> do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: No test / bench component for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
" so doing an all-in-one build."
Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
True (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps (LocalPackage -> Package
lpPackage LocalPackage
lp) Maybe Installed
minstalled
Just Package
tb -> do
Map PackageName (Either ConstructPlanException AddDepRes)
s <- forall s (m :: * -> *). MonadState s m => m s
get
Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall a b. (a -> b) -> a -> b
$ do
Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
tb
let writerFunc :: a -> a
writerFunc a
w = case Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
Left ConstructPlanException
_ -> forall a. Monoid a => a
mempty
Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
_ -> a
w
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res, forall {a}. Monoid a => a -> a
writerFunc)
case Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps -> do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: For " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
", successfully added package deps"
Bool
splitRequired <- Maybe Curator -> Bool
expectedTestOrBenchFailures forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Maybe Curator
mcurator
let isAllInOne :: Bool
isAllInOne = Bool -> Bool
not Bool
splitRequired
AddDepRes
adr <- Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
IsMutable)
-> M AddDepRes
installPackageGivenDeps Bool
isAllInOne (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps Package
tb Maybe Installed
minstalled (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps
let finalAllInOne :: Bool
finalAllInOne = case AddDepRes
adr of
ADRToInstall Task
_ | Bool
splitRequired -> Bool
False
AddDepRes
_ -> Bool
True
LocalPackage
-> Package
-> Bool
-> Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
addFinal LocalPackage
lp Package
tb Bool
finalAllInOne Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right AddDepRes
adr
Left ConstructPlanException
_ -> do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: Before trying cyclic plan, resetting lib result map to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Map PackageName (Either ConstructPlanException AddDepRes)
s
forall s (m :: * -> *). MonadState s m => s -> m ()
put Map PackageName (Either ConstructPlanException AddDepRes)
s
Either ConstructPlanException AddDepRes
res' <- Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
False (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps (LocalPackage -> Package
lpPackage LocalPackage
lp) Maybe Installed
minstalled
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. Either a b -> Bool
isRight Either ConstructPlanException AddDepRes
res') forall a b. (a -> b) -> a -> b
$ do
PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res'
LocalPackage
-> Package
-> Bool
-> Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
addFinal LocalPackage
lp Package
tb Bool
False Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return Either ConstructPlanException AddDepRes
res'
where
expectedTestOrBenchFailures :: Maybe Curator -> Bool
expectedTestOrBenchFailures Maybe Curator
maybeCurator = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
Curator
curator <- Maybe Curator
maybeCurator
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name (Curator -> Set PackageName
curatorExpectTestFailure Curator
curator) Bool -> Bool -> Bool
||
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name (Curator -> Set PackageName
curatorExpectBenchmarkFailure Curator
curator)
resolveDepsAndInstall :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled = do
Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package
case Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
Left ConstructPlanException
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ConstructPlanException
err
Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
IsMutable)
-> M AddDepRes
installPackageGivenDeps Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps
installPackageGivenDeps :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> ( Set PackageIdentifier
, Map PackageIdentifier GhcPkgId
, IsMutable )
-> M AddDepRes
installPackageGivenDeps :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
IsMutable)
-> M AddDepRes
installPackageGivenDeps Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled (Set PackageIdentifier
missing, Map PackageIdentifier GhcPkgId
present, IsMutable
minMutable) = do
let name :: PackageName
name = Package -> PackageName
packageName Package
package
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
Maybe Installed
mRightVersionInstalled <- case (Maybe Installed
minstalled, forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing) of
(Just Installed
installed, Bool
True) -> do
Bool
shouldInstall <- PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
shouldInstall then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Installed
installed
(Just Installed
_, Bool
False) -> do
let t :: Text
t = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName) (forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing)
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wDirty :: Map PackageName Text
wDirty = forall k a. k -> a -> Map k a
Map.singleton PackageName
name forall a b. (a -> b) -> a -> b
$ Text
"missing dependencies: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis Text
t }
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
(Maybe Installed
Nothing, Bool
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
let loc :: InstallLocation
loc = PackageSource -> InstallLocation
psLocation PackageSource
ps
mutable :: IsMutable
mutable = InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc forall a. Semigroup a => a -> a -> a
<> IsMutable
minMutable
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Installed
mRightVersionInstalled of
Just Installed
installed -> InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
Maybe Installed
Nothing -> Task -> AddDepRes
ADRToInstall Task
{ taskProvides :: PackageIdentifier
taskProvides = PackageName -> Version -> PackageIdentifier
PackageIdentifier
(Package -> PackageName
packageName Package
package)
(Package -> Version
packageVersion Package
package)
, taskConfigOpts :: TaskConfigOpts
taskConfigOpts = Set PackageIdentifier
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
TaskConfigOpts Set PackageIdentifier
missing forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
present Map PackageIdentifier GhcPkgId
missing'
in EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
(Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
Map PackageIdentifier GhcPkgId
allDeps
(PackageSource -> Bool
psLocal PackageSource
ps)
IsMutable
mutable
Package
package
, taskBuildHaddock :: Bool
taskBuildHaddock = Bool
buildHaddocks
, taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = Map PackageIdentifier GhcPkgId
present
, taskType :: TaskType
taskType =
case PackageSource
ps of
PSFilePath LocalPackage
lp ->
LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
_cp ->
IsMutable -> Package -> PackageLocationImmutable -> TaskType
TTRemotePackage IsMutable
mutable Package
package PackageLocationImmutable
pkgLoc
, taskAllInOne :: Bool
taskAllInOne = Bool
isAllInOne
, taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
, taskAnyMissing :: Bool
taskAnyMissing = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
, taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
}
packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig Package
pkg = Package -> BuildType
packageBuildType Package
pkg forall a. Eq a => a -> a -> Bool
== BuildType
Configure
updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M ()
updateLibMap :: PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
val = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Map PackageName (Either ConstructPlanException AddDepRes)
mp ->
case (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
mp, Either ConstructPlanException AddDepRes
val) of
(Just (Left DependencyCycleDetected{}), Left ConstructPlanException
_) -> Map PackageName (Either ConstructPlanException AddDepRes)
mp
(Maybe (Either ConstructPlanException AddDepRes),
Either ConstructPlanException AddDepRes)
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name Either ConstructPlanException AddDepRes
val Map PackageName (Either ConstructPlanException AddDepRes)
mp
addEllipsis :: Text -> Text
addEllipsis :: Text -> Text
addEllipsis Text
t
| Text -> Int
T.length Text
t forall a. Ord a => a -> a -> Bool
< Int
100 = Text
t
| Bool
otherwise = Int -> Text -> Text
T.take Int
97 Text
t forall a. Semigroup a => a -> a -> a
<> Text
"..."
addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps :: Package
-> M (Either
ConstructPlanException
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package = do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
Map PackageName DepValue
deps' <- Package -> M (Map PackageName DepValue)
packageDepsWithTools Package
package
[Either
(PackageName,
(VersionRange, Maybe (Version, BlobKey), BadDependency))
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
deps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName DepValue
deps') forall a b. (a -> b) -> a -> b
$ \(PackageName
depname, DepValue VersionRange
range DepType
depType) -> do
Either ConstructPlanException AddDepRes
eres <- PackageName -> M (Either ConstructPlanException AddDepRes)
addDep PackageName
depname
let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev = do
Map Version (Map Revision BlobKey)
vsAndRevs <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
YesRequireHackageIndex UsePreferredVersions
UsePreferredVersions PackageName
depname
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
Version
lappVer <- VersionRange -> Set Version -> Maybe Version
latestApplicableVersion VersionRange
range forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map Version (Map Revision BlobKey)
vsAndRevs
Map Revision BlobKey
revs <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Version
lappVer Map Version (Map Revision BlobKey)
vsAndRevs
(BlobKey
cabalHash, Map Revision BlobKey
_) <- forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map Revision BlobKey
revs
forall a. a -> Maybe a
Just (Version
lappVer, BlobKey
cabalHash)
case Either ConstructPlanException AddDepRes
eres of
Left ConstructPlanException
e -> do
forall {m :: * -> *}.
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range forall a. Maybe a
Nothing
let bd :: BadDependency
bd =
case ConstructPlanException
e of
UnknownPackage PackageName
name -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageName
name forall a. Eq a => a -> a -> Bool
== PackageName
depname) BadDependency
NotInBuildPlan
DependencyCycleDetected [PackageName]
names -> [PackageName] -> BadDependency
BDDependencyCycleDetected [PackageName]
names
DependencyPlanFailures Package
_ Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
_ -> Version -> BadDependency
Couldn'tResolveItsDependencies (Package -> Version
packageVersion Package
package)
Maybe (Version, BlobKey)
mlatestApplicable <- M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
mlatestApplicable, BadDependency
bd))
Right AddDepRes
adr | DepType
depType forall a. Eq a => a -> a -> Bool
== DepType
AsLibrary Bool -> Bool -> Bool
&& Bool -> Bool
not (AddDepRes -> Bool
adrHasLibrary AddDepRes
adr) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, forall a. Maybe a
Nothing, BadDependency
HasNoLibrary))
Right AddDepRes
adr -> do
forall {m :: * -> *}.
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range forall a. Maybe a
Nothing
Bool
inRange <- if AddDepRes -> Version
adrVersion AddDepRes
adr Version -> VersionRange -> Bool
`withinRange` VersionRange
range
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
let warn_ :: Text -> m ()
warn_ Text
reason =
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = (Text
msgforall a. a -> [a] -> [a]
:) }
where
msg :: Text
msg = [Text] -> Text
T.concat
[ Text
"WARNING: Ignoring "
, [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
, Text
"'s bounds on "
, [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
depname
, Text
" ("
, VersionRange -> Text
versionRangeText VersionRange
range
, Text
"); using "
, [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)
, Text
".\nReason: "
, Text
reason
, Text
"."
]
Bool
allowNewer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
if Bool
allowNewer
then do
forall {m :: * -> *}. MonadWriter W m => Text -> m ()
warn_ Text
"allow-newer enabled"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Bool
x <- PackageName
-> Version
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
inSnapshot (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
Bool
y <- PackageName
-> Version
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
inSnapshot PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)
if Bool
x Bool -> Bool -> Bool
&& Bool
y
then do
forall {m :: * -> *}. MonadWriter W m => Text -> m ()
warn_ Text
"trusting snapshot over cabal file dependency information"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
if Bool
inRange
then case AddDepRes
adr of
ADRToInstall Task
task -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
(forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task, forall k a. Map k a
Map.empty, Task -> IsMutable
taskTargetIsMutable Task
task)
ADRFound InstallLocation
loc (Executable PackageIdentifier
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
(forall a. Set a
Set.empty, forall k a. Map k a
Map.empty, InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc)
ADRFound InstallLocation
loc (Library PackageIdentifier
ident GhcPkgId
gid Maybe (Either License License)
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
(forall a. Set a
Set.empty, forall k a. k -> a -> Map k a
Map.singleton PackageIdentifier
ident GhcPkgId
gid, InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc)
else do
Maybe (Version, BlobKey)
mlatestApplicable <- M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
mlatestApplicable, Version -> BadDependency
DependencyMismatch forall a b. (a -> b) -> a -> b
$ AddDepRes -> Version
adrVersion AddDepRes
adr))
case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
(PackageName,
(VersionRange, Maybe (Version, BlobKey), BadDependency))
(Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
deps of
([], [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
IsMutable)]
pairs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
IsMutable)]
pairs
([(PackageName,
(VersionRange, Maybe (Version, BlobKey), BadDependency))]
errs, [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
IsMutable)]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Package
-> Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> ConstructPlanException
DependencyPlanFailures
Package
package
(forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName,
(VersionRange, Maybe (Version, BlobKey), BadDependency))]
errs)
where
adrVersion :: AddDepRes -> Version
adrVersion (ADRToInstall Task
task) = PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
adrVersion (ADRFound InstallLocation
_ Installed
installed) = Installed -> Version
installedVersion Installed
installed
addParent :: PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range Maybe Version
mversion = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wParents :: ParentMap
wParents = forall k a. Map k a -> MonoidMap k a
MonoidMap forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton PackageName
depname (First Version, [(PackageIdentifier, VersionRange)])
val }
where
val :: (First Version, [(PackageIdentifier, VersionRange)])
val = (forall a. Maybe a -> First a
First Maybe Version
mversion, [(Package -> PackageIdentifier
packageIdentifier Package
package, VersionRange
range)])
adrHasLibrary :: AddDepRes -> Bool
adrHasLibrary :: AddDepRes -> Bool
adrHasLibrary (ADRToInstall Task
task) = Task -> Bool
taskHasLibrary Task
task
adrHasLibrary (ADRFound InstallLocation
_ Library{}) = Bool
True
adrHasLibrary (ADRFound InstallLocation
_ Executable{}) = Bool
False
taskHasLibrary :: Task -> Bool
taskHasLibrary :: Task -> Bool
taskHasLibrary Task
task =
case Task -> TaskType
taskType Task
task of
TTLocalMutable LocalPackage
lp -> Package -> Bool
packageHasLibrary forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package -> Bool
packageHasLibrary Package
p
packageHasLibrary :: Package -> Bool
packageHasLibrary :: Package -> Bool
packageHasLibrary Package
p =
Bool -> Bool
not (forall a. Set a -> Bool
Set.null (Package -> Set Text
packageInternalLibraries Package
p)) Bool -> Bool -> Bool
||
case Package -> PackageLibraries
packageLibraries Package
p of
HasLibraries Set Text
_ -> Bool
True
PackageLibraries
NoLibraries -> Bool
False
checkDirtiness :: PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> M Bool
checkDirtiness :: PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks = do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
Maybe ConfigCache
moldOpts <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Installed -> RIO env (Maybe ConfigCache)
tryGetFlagCache Installed
installed
let configOpts :: ConfigureOpts
configOpts = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
(Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
Map PackageIdentifier GhcPkgId
present
(PackageSource -> Bool
psLocal PackageSource
ps)
(InstallLocation -> IsMutable
installLocationIsMutable forall a b. (a -> b) -> a -> b
$ PackageSource -> InstallLocation
psLocation PackageSource
ps)
Package
package
wantConfigCache :: ConfigCache
wantConfigCache = ConfigCache
{ configCacheOpts :: ConfigureOpts
configCacheOpts = ConfigureOpts
configOpts
, configCacheDeps :: Set GhcPkgId
configCacheDeps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
present
, configCacheComponents :: Set ByteString
configCacheComponents =
case PackageSource
ps of
PSFilePath LocalPackage
lp -> forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
PSRemote{} -> forall a. Set a
Set.empty
, configCacheHaddock :: Bool
configCacheHaddock = Bool
buildHaddocks
, configCachePkgSrc :: CachePkgSrc
configCachePkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
, configCachePathEnvVar :: Text
configCachePathEnvVar = Ctx -> Text
pathEnvVar Ctx
ctx
}
config :: Config
config = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL Ctx
ctx
Maybe Text
mreason <-
case Maybe ConfigCache
moldOpts of
Maybe ConfigCache
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"old configure information not found"
Just ConfigCache
oldOpts
| Just Text
reason <- Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff Config
config ConfigCache
oldOpts ConfigCache
wantConfigCache -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
reason
| Bool
True <- PackageSource -> Bool
psForceDirty PackageSource
ps -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"--force-dirty specified"
| Bool
otherwise -> do
Maybe (Set [Char])
dirty <- forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set [Char]))
psDirty PackageSource
ps
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
case Maybe (Set [Char])
dirty of
Just Set [Char]
files -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"local file changes: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set [Char]
files)
Maybe (Set [Char])
Nothing -> forall a. Maybe a
Nothing
case Maybe Text
mreason of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just Text
reason -> do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wDirty :: Map PackageName Text
wDirty = forall k a. k -> a -> Map k a
Map.singleton (Package -> PackageName
packageName Package
package) Text
reason }
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff Config
config ConfigCache
old ConfigCache
new
| ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
old forall a. Eq a => a -> a -> Bool
/= ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Text
"switching from " forall a. Semigroup a => a -> a -> a
<>
CachePkgSrc -> Text
pkgSrcName (ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
old) forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<>
CachePkgSrc -> Text
pkgSrcName (ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new)
| Bool -> Bool
not (ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
new forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
old) = forall a. a -> Maybe a
Just Text
"dependencies changed"
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set ByteString
newComponents =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"components added: " Text -> Text -> Text
`T.append` Text -> [Text] -> Text
T.intercalate Text
", "
(forall a b. (a -> b) -> [a] -> [b]
map (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) (forall a. Set a -> [a]
Set.toList Set ByteString
newComponents))
| Bool -> Bool
not (ConfigCache -> Bool
configCacheHaddock ConfigCache
old) Bool -> Bool -> Bool
&& ConfigCache -> Bool
configCacheHaddock ConfigCache
new = forall a. a -> Maybe a
Just Text
"rebuilding with haddocks"
| [Text]
oldOpts forall a. Eq a => a -> a -> Bool
/= [Text]
newOpts = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"flags changed from "
, forall a. Show a => a -> [Char]
show [Text]
oldOpts
, [Char]
" to "
, forall a. Show a => a -> [Char]
show [Text]
newOpts
]
| Bool
otherwise = forall a. Maybe a
Nothing
where
stripGhcOptions :: [Text] -> [Text]
stripGhcOptions =
[Text] -> [Text]
go
where
go :: [Text] -> [Text]
go [] = []
go (Text
"--ghc-option":Text
x:[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
go (Text
"--ghc-options":Text
x:[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
go ((Text -> Text -> Maybe Text
T.stripPrefix Text
"--ghc-option=" -> Just Text
x):[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
go ((Text -> Text -> Maybe Text
T.stripPrefix Text
"--ghc-options=" -> Just Text
x):[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
go (Text
x:[Text]
xs) = Text
x forall a. a -> [a] -> [a]
: [Text] -> [Text]
go [Text]
xs
go' :: WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
wc Text
x [Text]
xs = WhichCompiler -> Text -> [Text] -> [Text]
checkKeepers WhichCompiler
wc Text
x forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
go [Text]
xs
checkKeepers :: WhichCompiler -> Text -> [Text] -> [Text]
checkKeepers WhichCompiler
wc Text
x [Text]
xs =
case forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isKeeper forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
x of
[] -> [Text]
xs
[Text]
keepers -> [Char] -> Text
T.pack (WhichCompiler -> [Char]
compilerOptionsCabalFlag WhichCompiler
wc) forall a. a -> [a] -> [a]
: [Text] -> Text
T.unwords [Text]
keepers forall a. a -> [a] -> [a]
: [Text]
xs
isKeeper :: Text -> Bool
isKeeper = (forall a. Eq a => a -> a -> Bool
== Text
"-fhpc")
userOpts :: ConfigCache -> [Text]
userOpts = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isStackOpt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Config -> Bool
configRebuildGhcOptions Config
config
then forall a. a -> a
id
else [Text] -> [Text]
stripGhcOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(ConfigureOpts [[Char]]
x [[Char]]
y) -> [[Char]]
x forall a. [a] -> [a] -> [a]
++ [[Char]]
y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigCache -> ConfigureOpts
configCacheOpts
([Text]
oldOpts, [Text]
newOpts) = forall {a}. Eq a => [a] -> [a] -> ([a], [a])
removeMatching (ConfigCache -> [Text]
userOpts ConfigCache
old) (ConfigCache -> [Text]
userOpts ConfigCache
new)
removeMatching :: [a] -> [a] -> ([a], [a])
removeMatching (a
x:[a]
xs) (a
y:[a]
ys)
| a
x forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a] -> ([a], [a])
removeMatching [a]
xs [a]
ys
removeMatching [a]
xs [a]
ys = ([a]
xs, [a]
ys)
newComponents :: Set ByteString
newComponents = ConfigCache -> Set ByteString
configCacheComponents ConfigCache
new forall {a}. Ord a => Set a -> Set a -> Set a
`Set.difference` ConfigCache -> Set ByteString
configCacheComponents ConfigCache
old
pkgSrcName :: CachePkgSrc -> Text
pkgSrcName (CacheSrcLocal [Char]
fp) = [Char] -> Text
T.pack [Char]
fp
pkgSrcName CachePkgSrc
CacheSrcUpstream = Text
"upstream source"
psForceDirty :: PackageSource -> Bool
psForceDirty :: PackageSource -> Bool
psForceDirty (PSFilePath LocalPackage
lp) = LocalPackage -> Bool
lpForceDirty LocalPackage
lp
psForceDirty PSRemote{} = Bool
False
psDirty
:: (MonadIO m, HasEnvConfig env, MonadReader env m)
=> PackageSource
-> m (Maybe (Set FilePath))
psDirty :: forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set [Char]))
psDirty (PSFilePath LocalPackage
lp) = forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith forall a b. (a -> b) -> a -> b
$ LocalPackage -> MemoizedWith EnvConfig (Maybe (Set [Char]))
lpDirtyFiles LocalPackage
lp
psDirty PSRemote {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
psLocal :: PackageSource -> Bool
psLocal :: PackageSource -> Bool
psLocal (PSFilePath LocalPackage
_ ) = Bool
True
psLocal PSRemote{} = Bool
False
psLocation :: PackageSource -> InstallLocation
psLocation :: PackageSource -> InstallLocation
psLocation (PSFilePath LocalPackage
_) = InstallLocation
Local
psLocation PSRemote{} = InstallLocation
Snap
packageDepsWithTools :: Package -> M (Map PackageName DepValue)
packageDepsWithTools :: Package -> M (Map PackageName DepValue)
packageDepsWithTools Package
p = do
[ToolWarning]
warnings <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Package -> Set ExeName
packageUnknownTools Package
p) forall a b. (a -> b) -> a -> b
$
\name :: ExeName
name@(ExeName Text
toolName) -> do
let settings :: EnvSettings
settings = EnvSettings
minimalEnvSettings { esIncludeLocals :: Bool
esIncludeLocals = Bool
True }
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
settings
Either ProcessException [Char]
mfound <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
toolName
case Either ProcessException [Char]
mfound of
Left ProcessException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExeName -> PackageName -> ToolWarning
ToolWarning ExeName
name (Package -> PackageName
packageName Package
p)
Right [Char]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = (forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> Text
toolWarningText [ToolWarning]
warnings forall a. [a] -> [a] -> [a]
++) }
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Package -> Map PackageName DepValue
packageDeps Package
p
data ToolWarning = ToolWarning ExeName PackageName
deriving Int -> ToolWarning -> ShowS
[ToolWarning] -> ShowS
ToolWarning -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ToolWarning] -> ShowS
$cshowList :: [ToolWarning] -> ShowS
show :: ToolWarning -> [Char]
$cshow :: ToolWarning -> [Char]
showsPrec :: Int -> ToolWarning -> ShowS
$cshowsPrec :: Int -> ToolWarning -> ShowS
Show
toolWarningText :: ToolWarning -> Text
toolWarningText :: ToolWarning -> Text
toolWarningText (ToolWarning (ExeName Text
toolName) PackageName
pkgName') =
Text
"No packages found in snapshot which provide a " forall a. Semigroup a => a -> a -> a
<>
[Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Text
toolName) forall a. Semigroup a => a -> a -> a
<>
Text
" executable, which is a build-tool dependency of " forall a. Semigroup a => a -> a -> a
<>
[Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
pkgName')
stripLocals :: Plan -> Plan
stripLocals :: Plan -> Plan
stripLocals Plan
plan = Plan
plan
{ planTasks :: Map PackageName Task
planTasks = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
, planFinals :: Map PackageName Task
planFinals = forall k a. Map k a
Map.empty
, planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal = forall k a. Map k a
Map.empty
, planInstallExes :: Map Text InstallLocation
planInstallExes = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= InstallLocation
Local) forall a b. (a -> b) -> a -> b
$ Plan -> Map Text InstallLocation
planInstallExes Plan
plan
}
where
checkTask :: Task -> Bool
checkTask Task
task = Task -> InstallLocation
taskLocation Task
task forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap
stripNonDeps :: Set PackageName -> Plan -> Plan
stripNonDeps :: Set PackageName -> Plan -> Plan
stripNonDeps Set PackageName
deps Plan
plan = Plan
plan
{ planTasks :: Map PackageName Task
planTasks = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
, planFinals :: Map PackageName Task
planFinals = forall k a. Map k a
Map.empty
, planInstallExes :: Map Text InstallLocation
planInstallExes = forall k a. Map k a
Map.empty
}
where
checkTask :: Task -> Bool
checkTask Task
task = Task -> PackageIdentifier
taskProvides Task
task forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageIdentifier
missingForDeps
providesDep :: Task -> Bool
providesDep Task
task = PackageIdentifier -> PackageName
pkgName (Task -> PackageIdentifier
taskProvides Task
task) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
deps
missing :: Map PackageIdentifier (Set PackageIdentifier)
missing = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Task -> PackageIdentifier
taskProvides forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TaskConfigOpts -> Set PackageIdentifier
tcoMissing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> TaskConfigOpts
taskConfigOpts) forall a b. (a -> b) -> a -> b
$
forall k a. Map k a -> [a]
Map.elems (Plan -> Map PackageName Task
planTasks Plan
plan)
missingForDeps :: Set PackageIdentifier
missingForDeps = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan) forall a b. (a -> b) -> a -> b
$ \Task
task ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Task -> Bool
providesDep Task
task) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
MonadState (Set PackageIdentifier) m =>
[PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing forall a. Monoid a => a
mempty (Task -> PackageIdentifier
taskProvides Task
task)
collectMissing :: [PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
dependents PackageIdentifier
pid = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
pid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageIdentifier]
dependents) forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[Char]
"Unexpected: task cycle for " forall a. Semigroup a => a -> a -> a
<> PackageName -> [Char]
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pid)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify'(forall a. Semigroup a => a -> a -> a
<> forall a. a -> Set a
Set.singleton PackageIdentifier
pid)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing (PackageIdentifier
pidforall a. a -> [a] -> [a]
:[PackageIdentifier]
dependents)) (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageIdentifier
pid Map PackageIdentifier (Set PackageIdentifier)
missing)
inSnapshot :: PackageName -> Version -> M Bool
inSnapshot :: PackageName
-> Version
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
inSnapshot PackageName
name Version
version = do
Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
PackageInfo
ps <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (Ctx -> CombinedMap
combinedMap Ctx
ctx)
case PackageInfo
ps of
PIOnlySource (PSRemote PackageLocationImmutable
_ Version
srcVersion FromSnapshot
FromSnapshot CommonPackage
_) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Version
srcVersion forall a. Eq a => a -> a -> Bool
== Version
version
PIBoth (PSRemote PackageLocationImmutable
_ Version
srcVersion FromSnapshot
FromSnapshot CommonPackage
_) Installed
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Version
srcVersion forall a. Eq a => a -> a -> Bool
== Version
version
PIOnlyInstalled InstallLocation
loc (Library PackageIdentifier
pid GhcPkgId
_gid Maybe (Either License License)
_lic) ->
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (InstallLocation
loc forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) forall a b. (a -> b) -> a -> b
$
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pid forall a. Eq a => a -> a -> Bool
== Version
version) forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a
Just Bool
True
PackageInfo
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
data ConstructPlanException
= DependencyCycleDetected [PackageName]
| DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
| UnknownPackage PackageName
deriving (Typeable, ConstructPlanException -> ConstructPlanException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructPlanException -> ConstructPlanException -> Bool
$c/= :: ConstructPlanException -> ConstructPlanException -> Bool
== :: ConstructPlanException -> ConstructPlanException -> Bool
$c== :: ConstructPlanException -> ConstructPlanException -> Bool
Eq, Int -> ConstructPlanException -> ShowS
[ConstructPlanException] -> ShowS
ConstructPlanException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConstructPlanException] -> ShowS
$cshowList :: [ConstructPlanException] -> ShowS
show :: ConstructPlanException -> [Char]
$cshow :: ConstructPlanException -> [Char]
showsPrec :: Int -> ConstructPlanException -> ShowS
$cshowsPrec :: Int -> ConstructPlanException -> ShowS
Show)
type LatestApplicableVersion = Maybe (Version, BlobKey)
data BadDependency
= NotInBuildPlan
| Couldn'tResolveItsDependencies Version
| DependencyMismatch Version
| HasNoLibrary
| BDDependencyCycleDetected ![PackageName]
deriving (Typeable, BadDependency -> BadDependency -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BadDependency -> BadDependency -> Bool
$c/= :: BadDependency -> BadDependency -> Bool
== :: BadDependency -> BadDependency -> Bool
$c== :: BadDependency -> BadDependency -> Bool
Eq, Eq BadDependency
BadDependency -> BadDependency -> Bool
BadDependency -> BadDependency -> Ordering
BadDependency -> BadDependency -> BadDependency
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BadDependency -> BadDependency -> BadDependency
$cmin :: BadDependency -> BadDependency -> BadDependency
max :: BadDependency -> BadDependency -> BadDependency
$cmax :: BadDependency -> BadDependency -> BadDependency
>= :: BadDependency -> BadDependency -> Bool
$c>= :: BadDependency -> BadDependency -> Bool
> :: BadDependency -> BadDependency -> Bool
$c> :: BadDependency -> BadDependency -> Bool
<= :: BadDependency -> BadDependency -> Bool
$c<= :: BadDependency -> BadDependency -> Bool
< :: BadDependency -> BadDependency -> Bool
$c< :: BadDependency -> BadDependency -> Bool
compare :: BadDependency -> BadDependency -> Ordering
$ccompare :: BadDependency -> BadDependency -> Ordering
Ord, Int -> BadDependency -> ShowS
[BadDependency] -> ShowS
BadDependency -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BadDependency] -> ShowS
$cshowList :: [BadDependency] -> ShowS
show :: BadDependency -> [Char]
$cshow :: BadDependency -> [Char]
showsPrec :: Int -> BadDependency -> ShowS
$cshowsPrec :: Int -> BadDependency -> ShowS
Show)
pprintExceptions
:: [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions :: [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions [ConstructPlanException]
exceptions Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parentMap Set PackageName
wanted' Map PackageName [PackageName]
prunedGlobalDeps =
forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
[ [Char] -> StyleDoc
flow [Char]
"While constructing the build plan, the following exceptions were encountered:"
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
, forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse (StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConstructPlanException -> Maybe StyleDoc
pprintException [ConstructPlanException]
exceptions'))
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
, [Char] -> StyleDoc
flow [Char]
"Some different approaches to resolving this:"
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
] forall a. [a] -> [a] -> [a]
++
(if Bool -> Bool
not Bool
onlyHasDependencyMismatches then [] else
[ StyleDoc
" *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"Set 'allow-newer: true' in " StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty (Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot) StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"to ignore all version constraints and build anyway.")
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
]
) forall a. [a] -> [a] -> [a]
++ [StyleDoc]
addExtraDepsRecommendations
where
exceptions' :: [ConstructPlanException]
exceptions' = [ConstructPlanException]
exceptions
addExtraDepsRecommendations :: [StyleDoc]
addExtraDepsRecommendations
| forall k a. Map k a -> Bool
Map.null Map PackageName (Version, BlobKey)
extras = []
| (Just (Version, BlobKey)
_) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> PackageName
mkPackageName [Char]
"base") Map PackageName (Version, BlobKey)
extras =
[ StyleDoc
" *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.")
, StyleDoc
line
]
| Bool
otherwise =
[ StyleDoc
" *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align
(Style -> StyleDoc -> StyleDoc
style Style
Recommendation ([Char] -> StyleDoc
flow [Char]
"Recommended action:") StyleDoc -> StyleDoc -> StyleDoc
<+>
[Char] -> StyleDoc
flow [Char]
"try adding the following to your extra-deps in" StyleDoc -> StyleDoc -> StyleDoc
<+>
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
, [StyleDoc] -> StyleDoc
vsep (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. IsString a => (PackageName, (Version, BlobKey)) -> a
pprintExtra (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Version, BlobKey)
extras))
, StyleDoc
line
]
extras :: Map PackageName (Version, BlobKey)
extras = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras [ConstructPlanException]
exceptions'
getExtras :: ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras DependencyCycleDetected{} = forall k a. Map k a
Map.empty
getExtras UnknownPackage{} = forall k a. Map k a
Map.empty
getExtras (DependencyPlanFailures Package
_ Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {k} {a} {a} {b}.
(k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m
where
go :: (k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go (k
name, (a
_range, Just (a
version,b
cabalHash), BadDependency
NotInBuildPlan)) =
forall k a. k -> a -> Map k a
Map.singleton k
name (a
version,b
cabalHash)
go (k
name, (a
_range, Just (a
version,b
cabalHash), DependencyMismatch{})) =
forall k a. k -> a -> Map k a
Map.singleton k
name (a
version, b
cabalHash)
go (k, (a, Maybe (a, b), BadDependency))
_ = forall k a. Map k a
Map.empty
pprintExtra :: (PackageName, (Version, BlobKey)) -> a
pprintExtra (PackageName
name, (Version
version, BlobKey SHA256
cabalHash FileSize
cabalSize)) =
let cfInfo :: CabalFileInfo
cfInfo = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
cabalHash (forall a. a -> Maybe a
Just FileSize
cabalSize)
packageIdRev :: PackageIdentifierRevision
packageIdRev = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfInfo
in forall a. IsString a => [Char] -> a
fromString ([Char]
"- " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Utf8Builder -> Text
utf8BuilderToText (forall a. Display a => a -> Utf8Builder
RIO.display PackageIdentifierRevision
packageIdRev)))
allNotInBuildPlan :: Set PackageName
allNotInBuildPlan = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructPlanException -> [PackageName]
toNotInBuildPlan [ConstructPlanException]
exceptions'
toNotInBuildPlan :: ConstructPlanException -> [PackageName]
toNotInBuildPlan (DependencyPlanFailures Package
_ Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName
_, (VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
badDep)) -> BadDependency
badDep forall a. Eq a => a -> a -> Bool
== BadDependency
NotInBuildPlan) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps
toNotInBuildPlan ConstructPlanException
_ = []
onlyHasDependencyMismatches :: Bool
onlyHasDependencyMismatches = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructPlanException -> Bool
go [ConstructPlanException]
exceptions'
where
go :: ConstructPlanException -> Bool
go DependencyCycleDetected{} = Bool
False
go UnknownPackage{} = Bool
False
go (DependencyPlanFailures Package
_ Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
depErr) -> BadDependency -> Bool
isMismatch BadDependency
depErr) (forall k a. Map k a -> [a]
M.elems Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m)
isMismatch :: BadDependency -> Bool
isMismatch DependencyMismatch{} = Bool
True
isMismatch Couldn'tResolveItsDependencies{} = Bool
True
isMismatch BadDependency
_ = Bool
False
pprintException :: ConstructPlanException -> Maybe StyleDoc
pprintException (DependencyCycleDetected [PackageName]
pNames) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
[Char] -> StyleDoc
flow [Char]
"Dependency cycle detected in packages:" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
Int -> StyleDoc -> StyleDoc
indent Int
4 (StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"[" StyleDoc
"]" StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) [PackageName]
pNames))
pprintException (DependencyPlanFailures Package
pkg Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}.
(PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (forall k a. Map k a -> [(k, a)]
Map.toList Map
PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) of
[] -> forall a. Maybe a
Nothing
[StyleDoc]
depErrors -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
[Char] -> StyleDoc
flow [Char]
"In the dependencies for" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgIdent forall a. Semigroup a => a -> a -> a
<>
Map FlagName Bool -> StyleDoc
pprintFlags (Package -> Map FlagName Bool
packageFlags Package
pkg) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
Int -> StyleDoc -> StyleDoc
indent Int
4 ([StyleDoc] -> StyleDoc
vsep [StyleDoc]
depErrors) forall a. Semigroup a => a -> a -> a
<>
case ParentMap
-> Set PackageName -> PackageName -> Maybe [PackageIdentifier]
getShortestDepsPath ParentMap
parentMap Set PackageName
wanted' (Package -> PackageName
packageName Package
pkg) of
Maybe [PackageIdentifier]
Nothing -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"needed for unknown reason - stack invariant violated."
Just [] -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"needed since" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgName' StyleDoc -> StyleDoc -> StyleDoc
<+> [Char] -> StyleDoc
flow [Char]
"is a build target."
Just (PackageIdentifier
target:[PackageIdentifier]
path) -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"needed due to" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
" -> " [StyleDoc]
pathElems
where
pathElems :: [StyleDoc]
pathElems =
[Style -> StyleDoc -> StyleDoc
style Style
Target forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageIdentifier
target] forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString) [PackageIdentifier]
path forall a. [a] -> [a] -> [a]
++
[StyleDoc
pkgIdent]
where
pkgName' :: StyleDoc
pkgName' = Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
pkg
pkgIdent :: StyleDoc
pkgIdent = Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdentifier Package
pkg
pprintException (UnknownPackage PackageName
name)
| PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
allNotInBuildPlan = forall a. Maybe a
Nothing
| PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Can't build a package with same name as a wired-in-package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ PackageName
name)
| Just [PackageName]
pruned <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName [PackageName]
prunedGlobalDeps =
let prunedDeps :: [StyleDoc]
prunedDeps = forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) [PackageName]
pruned
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Can't use GHC boot package" StyleDoc -> StyleDoc -> StyleDoc
<+>
(Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
[Char] -> StyleDoc
flow [Char]
"when it has an overridden dependency (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
[Char] -> StyleDoc
flow [Char]
"you need to add the following as explicit dependencies to the project:" StyleDoc -> StyleDoc -> StyleDoc
<+>
StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
", " [StyleDoc]
prunedDeps
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Unknown package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ PackageName
name)
pprintFlags :: Map FlagName Bool -> StyleDoc
pprintFlags Map FlagName Bool
flags
| forall k a. Map k a -> Bool
Map.null Map FlagName Bool
flags = StyleDoc
""
| Bool
otherwise = StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Semigroup a, IsString a) => (FlagName, Bool) -> a
pprintFlag forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
flags
pprintFlag :: (FlagName, Bool) -> a
pprintFlag (FlagName
name, Bool
True) = a
"+" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (FlagName -> [Char]
flagNameString FlagName
name)
pprintFlag (FlagName
name, Bool
False) = a
"-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (FlagName -> [Char]
flagNameString FlagName
name)
pprintDep :: (PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (PackageName
name, (VersionRange
range, Maybe (Version, b)
mlatestApplicable, BadDependency
badDep)) = case BadDependency
badDep of
BadDependency
NotInBuildPlan
| PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map PackageName [PackageName]
prunedGlobalDeps -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
StyleDoc -> StyleDoc
align ((if VersionRange
range forall a. Eq a => a -> a -> Bool
== VersionRange
Cabal.anyVersion
then [Char] -> StyleDoc
flow [Char]
"needed"
else [Char] -> StyleDoc
flow [Char]
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
[Char] -> StyleDoc
flow [Char]
"but this GHC boot package has been pruned (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
[Char] -> StyleDoc
flow [Char]
"you need to add the package explicitly to extra-deps" StyleDoc -> StyleDoc -> StyleDoc
<+>
Maybe Version -> StyleDoc
latestApplicable forall a. Maybe a
Nothing)
| Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
StyleDoc -> StyleDoc
align ((if VersionRange
range forall a. Eq a => a -> a -> Bool
== VersionRange
Cabal.anyVersion
then [Char] -> StyleDoc
flow [Char]
"needed"
else [Char] -> StyleDoc
flow [Char]
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
[Char] -> StyleDoc
flow [Char]
"but the stack configuration has no specified version" StyleDoc -> StyleDoc -> StyleDoc
<+>
Maybe Version -> StyleDoc
latestApplicable forall a. Maybe a
Nothing)
DependencyMismatch Version
version -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
(Style -> StyleDoc -> StyleDoc
style Style
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString) (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) StyleDoc -> StyleDoc -> StyleDoc
<+>
StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"from stack configuration does not match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange StyleDoc -> StyleDoc -> StyleDoc
<+>
Maybe Version -> StyleDoc
latestApplicable (forall a. a -> Maybe a
Just Version
version))
Couldn'tResolveItsDependencies Version
_version -> forall a. Maybe a
Nothing
BadDependency
HasNoLibrary -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"is a library dependency, but the package provides no library")
BDDependencyCycleDetected [PackageName]
names -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ [Char]
"dependency cycle detected: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString [PackageName]
names))
where
goodRange :: StyleDoc
goodRange = Style -> StyleDoc -> StyleDoc
style Style
Good (forall a. IsString a => [Char] -> a
fromString (forall a. Pretty a => a -> [Char]
Cabal.display VersionRange
range))
latestApplicable :: Maybe Version -> StyleDoc
latestApplicable Maybe Version
mversion =
case Maybe (Version, b)
mlatestApplicable of
Maybe (Version, b)
Nothing
| forall a. Maybe a -> Bool
isNothing Maybe Version
mversion ->
[Char] -> StyleDoc
flow [Char]
"(no package with that name found, perhaps there is a typo in a package's build-depends or an omission from the stack.yaml packages list?)"
| Bool
otherwise -> StyleDoc
""
Just (Version
laVer, b
_)
| forall a. a -> Maybe a
Just Version
laVer forall a. Eq a => a -> a -> Bool
== Maybe Version
mversion -> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
[Char] -> StyleDoc
flow [Char]
"(latest matching version is specified)"
| Bool
otherwise -> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
[Char] -> StyleDoc
flow [Char]
"(latest matching version is" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
Good (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
laVer) forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"
getShortestDepsPath
:: ParentMap
-> Set PackageName
-> PackageName
-> Maybe [PackageIdentifier]
getShortestDepsPath :: ParentMap
-> Set PackageName -> PackageName -> Maybe [PackageIdentifier]
getShortestDepsPath (MonoidMap Map
PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap) Set PackageName
wanted' PackageName
name =
if forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted'
then forall a. a -> Maybe a
Just []
else case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map
PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap of
Maybe (First Version, [(PackageIdentifier, VersionRange)])
Nothing -> forall a. Maybe a
Nothing
Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest Int
256 Map PackageName DepsPath
paths0
where
paths0 :: Map PackageName DepsPath
paths0 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
ident, VersionRange
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident, PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident)) [(PackageIdentifier, VersionRange)]
parents
where
findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest Int
fuel Map PackageName DepsPath
_ | Int
fuel forall a. Ord a => a -> a -> Bool
<= Int
0 =
[PackageName -> Version -> PackageIdentifier
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
"stack-ran-out-of-jet-fuel") ([Int] -> Version
mkVersion [Int
0])]
findShortest Int
_ Map PackageName DepsPath
paths | forall k a. Map k a -> Bool
M.null Map PackageName DepsPath
paths = []
findShortest Int
fuel Map PackageName DepsPath
paths =
case [(PackageName, DepsPath)]
targets of
[] -> Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest (Int
fuel forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith DepsPath -> DepsPath -> DepsPath
chooseBest forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath [(PackageName, DepsPath)]
recurses
[(PackageName, DepsPath)]
_ -> let (DepsPath Int
_ Int
_ [PackageIdentifier]
path) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PackageName, DepsPath)]
targets) in [PackageIdentifier]
path
where
([(PackageName, DepsPath)]
targets, [(PackageName, DepsPath)]
recurses) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(PackageName
n, DepsPath
_) -> PackageName
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wanted') (forall k a. Map k a -> [(k, a)]
M.toList Map PackageName DepsPath
paths)
chooseBest :: DepsPath -> DepsPath -> DepsPath
chooseBest :: DepsPath -> DepsPath -> DepsPath
chooseBest DepsPath
x DepsPath
y = forall a. Ord a => a -> a -> a
max DepsPath
x DepsPath
y
extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath (PackageName
n, DepsPath
dp) =
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
n Map
PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap of
Maybe (First Version, [(PackageIdentifier, VersionRange)])
Nothing -> []
Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
pkgId, VersionRange
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId, PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath PackageIdentifier
pkgId DepsPath
dp)) [(PackageIdentifier, VersionRange)]
parents
data DepsPath = DepsPath
{ DepsPath -> Int
dpLength :: Int
, DepsPath -> Int
dpNameLength :: Int
, DepsPath -> [PackageIdentifier]
dpPath :: [PackageIdentifier]
}
deriving (DepsPath -> DepsPath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DepsPath -> DepsPath -> Bool
$c/= :: DepsPath -> DepsPath -> Bool
== :: DepsPath -> DepsPath -> Bool
$c== :: DepsPath -> DepsPath -> Bool
Eq, Eq DepsPath
DepsPath -> DepsPath -> Bool
DepsPath -> DepsPath -> Ordering
DepsPath -> DepsPath -> DepsPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DepsPath -> DepsPath -> DepsPath
$cmin :: DepsPath -> DepsPath -> DepsPath
max :: DepsPath -> DepsPath -> DepsPath
$cmax :: DepsPath -> DepsPath -> DepsPath
>= :: DepsPath -> DepsPath -> Bool
$c>= :: DepsPath -> DepsPath -> Bool
> :: DepsPath -> DepsPath -> Bool
$c> :: DepsPath -> DepsPath -> Bool
<= :: DepsPath -> DepsPath -> Bool
$c<= :: DepsPath -> DepsPath -> Bool
< :: DepsPath -> DepsPath -> Bool
$c< :: DepsPath -> DepsPath -> Bool
compare :: DepsPath -> DepsPath -> Ordering
$ccompare :: DepsPath -> DepsPath -> Ordering
Ord, Int -> DepsPath -> ShowS
[DepsPath] -> ShowS
DepsPath -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DepsPath] -> ShowS
$cshowList :: [DepsPath] -> ShowS
show :: DepsPath -> [Char]
$cshow :: DepsPath -> [Char]
showsPrec :: Int -> DepsPath -> ShowS
$cshowsPrec :: Int -> DepsPath -> ShowS
Show)
startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident = DepsPath
{ dpLength :: Int
dpLength = Int
1
, dpNameLength :: Int
dpNameLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> [Char]
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
, dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
}
extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath PackageIdentifier
ident DepsPath
dp = DepsPath
{ dpLength :: Int
dpLength = DepsPath -> Int
dpLength DepsPath
dp forall a. Num a => a -> a -> a
+ Int
1
, dpNameLength :: Int
dpNameLength = DepsPath -> Int
dpNameLength DepsPath
dp forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> [Char]
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
, dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
}
planDebug :: MonadIO m => String -> m ()
planDebug :: forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug = if Bool
False then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn else \[Char]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()