{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Stack.Build.ConstructPlan
( constructPlan
) where
import Control.Monad.RWS.Strict hiding ( (<>) )
import qualified Data.List as L
import qualified Data.Map.Merge.Strict as Map
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 Distribution.Types.BuildType ( BuildType (Configure) )
import Distribution.Types.PackageName ( mkPackageName )
import Generics.Deriving.Monoid ( memptydefault, mappenddefault )
import Path ( parent )
import RIO.Process ( HasProcessContext (..), findExecutable )
import RIO.State ( State, execState )
import Stack.Build.Cache ( tryGetFlagCache )
import Stack.Build.Haddock ( shouldHaddockDeps )
import Stack.Build.Source ( loadLocalPackage )
import Stack.Constants ( compilerOptionsCabalFlag )
import Stack.Package ( applyForceCustomBuild )
import Stack.Prelude hiding ( loadPackage )
import Stack.SourceMap ( getPLIVersion, mkProjectPackage )
import Stack.Types.Build
( CachePkgSrc (..), ConfigCache (..), Plan (..), Task (..)
, TaskConfigOpts (..), TaskType (..)
, installLocationIsMutable, taskIsTarget, taskLocation
, taskTargetIsMutable, toCachePkgSrc
)
import Stack.Types.Build.Exception
( BadDependency (..), BuildException (..)
, BuildPrettyException (..), ConstructPlanException (..)
)
import Stack.Types.BuildConfig
( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import Stack.Types.BuildOpts
( BuildOpts (..), BuildOptsCLI (..), BuildSubset (..) )
import Stack.Types.Compiler ( WhichCompiler (..) )
import Stack.Types.CompilerPaths
( CompilerPaths (..), HasCompiler (..) )
import Stack.Types.Config ( Config (..), HasConfig (..), stackRootL )
import Stack.Types.ConfigureOpts
( BaseConfigOpts (..), ConfigureOpts (..), configureOpts )
import Stack.Types.Curator ( Curator (..) )
import Stack.Types.Dependency
( DepValue (DepValue), DepType (AsLibrary) )
import Stack.Types.DumpPackage ( DumpPackage (..) )
import Stack.Types.EnvConfig
( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) )
import Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings )
import Stack.Types.GHCVariant ( HasGHCVariant (..) )
import Stack.Types.GhcPkgId ( GhcPkgId )
import Stack.Types.IsMutable ( IsMutable (..) )
import Stack.Types.NamedComponent ( exeComponents, renderComponent )
import Stack.Types.Package
( ExeName (..), InstallLocation (..), Installed (..)
, InstalledMap, LocalPackage (..), Package (..)
, PackageLibraries (..), PackageSource (..), installedVersion
, packageIdentifier, psVersion, runMemoizedWith
)
import Stack.Types.ParentMap ( ParentMap )
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.Runner ( HasRunner (..) )
import Stack.Types.SourceMap
( CommonPackage (..), DepPackage (..), FromSnapshot (..)
, GlobalPackage (..), SMTargets (..), SourceMap (..)
)
import Stack.Types.Version
( latestApplicableVersion, versionRangeText, withinRange )
import System.Environment ( lookupEnv )
import System.IO ( putStrLn )
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 c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ PackageSource
s -> PackageSource -> PackageInfo
PIOnlySource PackageSource
s))
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ (InstallLocation, Installed)
i -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled (InstallLocation, Installed)
i))
(forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\PackageName
_ PackageSource
s (InstallLocation, Installed)
i -> PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i))
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
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 -> [StyleDoc] -> [StyleDoc]
wWarnings :: !([StyleDoc] -> [StyleDoc])
, 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 where
platformL :: Lens' Ctx Platform
platformL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasPlatform env => Lens' env Platform
platformL
{-# INLINE platformL #-}
platformVariantL :: Lens' Ctx PlatformVariant
platformVariantL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasPlatform env => Lens' env PlatformVariant
platformVariantL
{-# INLINE platformVariantL #-}
instance HasGHCVariant Ctx where
ghcVariantL :: SimpleGetter Ctx GHCVariant
ghcVariantL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasGHCVariant env => SimpleGetter env GHCVariant
ghcVariantL
{-# INLINE ghcVariantL #-}
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 where
configL :: Lens' Ctx Config
configL = forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BuildConfig -> Config
bcConfig (\BuildConfig
x Config
y -> BuildConfig
x { bcConfig :: Config
bcConfig = Config
y })
{-# INLINE configL #-}
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 where
buildConfigL :: Lens' Ctx BuildConfig
buildConfigL = forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
EnvConfig -> BuildConfig
envConfigBuildConfig
(\EnvConfig
x BuildConfig
y -> EnvConfig
x { envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig
y })
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
$
[StyleDoc] -> StyleDoc
fillSep
[ [Char] -> StyleDoc
flow [Char]
"You are trying to upgrade or downgrade the"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
, [Char] -> StyleDoc
flow [Char]
"package, which is almost certainly not what you really \
\want. Please, consider using another GHC version if you \
\need a certain version of"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base" forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, [Char] -> StyleDoc
flow [Char]
"or removing"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
, [Char] -> StyleDoc
flow [Char]
"as an"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, [Char] -> StyleDoc
flow [Char]
"For further information, see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/3940" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
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 <- Version -> RIO env (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 [StyleDoc] -> [StyleDoc]
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
Map.empty
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn ([StyleDoc] -> [StyleDoc]
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)]
Map.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)]
Map.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
Map.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
Map.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
Map.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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> BuildPrettyException
ConstructPlanFailed
[ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parents (Ctx -> Set PackageName
wanted Ctx
ctx) Map PackageName [PackageName]
prunedGlobalDeps
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
$
\case
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 env (Map PackageName PackageSource)
getSources :: Version -> RIO env (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
let lpPackage' :: Package
lpPackage' =
Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Package
lpPackage' }
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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]
deriving (Int -> NotOnlyLocal -> ShowS
[NotOnlyLocal] -> ShowS
NotOnlyLocal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NotOnlyLocal] -> ShowS
$cshowList :: [NotOnlyLocal] -> ShowS
show :: NotOnlyLocal -> [Char]
$cshow :: NotOnlyLocal -> [Char]
showsPrec :: Int -> NotOnlyLocal -> ShowS
$cshowsPrec :: Int -> NotOnlyLocal -> ShowS
Show, Typeable)
instance Exception NotOnlyLocal where
displayException :: NotOnlyLocal -> [Char]
displayException (NotOnlyLocal [PackageName]
packages [Text]
exes) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Error: [S-1727]\n"
, [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]
L.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]
L.intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
exes)
, [Char]
"\n"
]
]
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)
-> [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_ DumpPackage -> State UnregisterState ()
go [DumpPackage]
keep) UnregisterState
initialUnregisterState
initialUnregisterState :: UnregisterState
initialUnregisterState = UnregisterState
{ usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = Map GhcPkgId (PackageIdentifier, Text)
toUnregister
, usKeep :: [DumpPackage]
usKeep = []
, usAnyAdded :: Bool
usAnyAdded = Bool
False
}
go :: DumpPackage -> State UnregisterState ()
go :: DumpPackage -> State UnregisterState ()
go DumpPackage
dp = do
UnregisterState
us <- forall s (m :: * -> *). MonadState s m => m s
get
case Map GhcPkgId (PackageIdentifier, Text)
-> PackageIdentifier
-> Maybe PackageIdentifier
-> [GhcPkgId]
-> Maybe Text
maybeUnregisterReason (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) PackageIdentifier
ident Maybe PackageIdentifier
mParentLibId [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
mParentLibId :: Maybe PackageIdentifier
mParentLibId = DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp
deps :: [GhcPkgId]
deps = DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp
maybeUnregisterReason ::
Map GhcPkgId (PackageIdentifier, Text)
-> PackageIdentifier
-> Maybe PackageIdentifier
-> [GhcPkgId]
-> Maybe Text
maybeUnregisterReason :: Map GhcPkgId (PackageIdentifier, Text)
-> PackageIdentifier
-> Maybe PackageIdentifier
-> [GhcPkgId]
-> Maybe Text
maybeUnregisterReason Map GhcPkgId (PackageIdentifier, Text)
toUnregister PackageIdentifier
ident Maybe PackageIdentifier
mParentLibId [GhcPkgId]
deps
| Just Task
task <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
relevantPkgName 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
relevantPkgId
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
relevantPkgName Map PackageName Text
dirtyReason
| (PackageIdentifier
dep, Text
_):[(PackageIdentifier, Text)]
_ <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map GhcPkgId (PackageIdentifier, Text)
toUnregister) [GhcPkgId]
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
relevantPkgId :: PackageIdentifier
relevantPkgId :: PackageIdentifier
relevantPkgId = forall a. a -> Maybe a -> a
fromMaybe PackageIdentifier
ident Maybe PackageIdentifier
mParentLibId
relevantPkgName :: PackageName
relevantPkgName :: PackageName
relevantPkgName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) PackageIdentifier -> PackageName
pkgName Maybe PackageIdentifier
mParentLibId
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
Map PackageName (Either ConstructPlanException AddDepRes)
libMap <- 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)
libMap 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 (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res
Maybe (Either ConstructPlanException AddDepRes)
Nothing -> PackageName -> M (Either ConstructPlanException AddDepRes)
addDep' PackageName
name
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
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
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. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
forall a. Semigroup a => a -> a -> a
<> [Char]
": "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Ctx -> [PackageName]
callStack Ctx
ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
case Maybe PackageInfo
mpackageInfo of
Maybe PackageInfo
Nothing -> do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
[Char]
"addDep': No package info for "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 PackageInfo
packageInfo -> PackageName
-> PackageInfo -> M (Either ConstructPlanException AddDepRes)
addDep'' PackageName
name PackageInfo
packageInfo
PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res
addDep'' ::
PackageName
-> PackageInfo
-> M (Either ConstructPlanException AddDepRes)
addDep'' :: PackageName
-> PackageInfo -> M (Either ConstructPlanException AddDepRes)
addDep'' PackageName
name PackageInfo
packageInfo = do
forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
[Char]
"addDep'': Package info for "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
forall a. Semigroup a => a -> a -> a
<> [Char]
": "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageInfo
packageInfo
case PackageInfo
packageInfo of
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
[PackageName]
cs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. [a] -> [a]
L.tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> [PackageName]
callStack)
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"No latest package revision found for"
forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
forall a. a -> [a] -> [a]
: [Char] -> StyleDoc
flow [Char]
"dependency callstack:"
forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList forall a. Maybe a
Nothing Bool
False
(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
. PackageName -> [Char]
packageNameString) [PackageName]
cs :: [StyleDoc])
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
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
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)
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
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. Semigroup 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. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
forall a. Semigroup 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)
libMap <- 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
forall a. Semigroup 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Map PackageName (Either ConstructPlanException AddDepRes)
libMap
forall s (m :: * -> *). MonadState s m => s -> m ()
put Map PackageName (Either ConstructPlanException AddDepRes)
libMap
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
(Maybe Installed
Nothing, Bool
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
Map.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
Map.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
Package
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
checkAndWarnForUnknownTools Package
package
let deps' :: Map PackageName DepValue
deps' = Package -> Map PackageName DepValue
packageDeps 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
let warn_ :: Bool -> StyleDoc -> m ()
warn_ Bool
isIgnoring StyleDoc
reason = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [StyleDoc] -> [StyleDoc]
wWarnings = (StyleDoc
msg:) }
where
msg :: StyleDoc
msg =
[StyleDoc] -> StyleDoc
fillSep
[ if Bool
isIgnoring then StyleDoc
"Ignoring" else [Char] -> StyleDoc
flow [Char]
"Not ignoring"
, Style -> StyleDoc -> StyleDoc
style Style
Current (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
package) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"'s"
, [Char] -> StyleDoc
flow [Char]
"bounds on"
, Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
depname)
, StyleDoc -> StyleDoc
parens (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ VersionRange -> Text
versionRangeText VersionRange
range)
, [Char] -> StyleDoc
flow [Char]
"and using"
, Style -> StyleDoc -> StyleDoc
style Style
Current (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
$
PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"Reason:"
, StyleDoc
reason forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
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
Maybe [PackageName]
allowNewerDeps <- 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 -> Maybe [PackageName]
configAllowNewerDeps
let inSnapshotCheck :: RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
inSnapshotCheck = 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 => Bool -> StyleDoc -> m ()
warn_ Bool
True
( [Char] -> StyleDoc
flow [Char]
"trusting snapshot over Cabal file dependency \
\information"
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
if Bool
allowNewer
then case Maybe [PackageName]
allowNewerDeps of
Maybe [PackageName]
Nothing -> do
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
, StyleDoc
"enabled"
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just [PackageName]
boundsIgnoredDeps -> do
let pkgName :: PackageName
pkgName = Package -> PackageName
packageName Package
package
pkgName' :: StyleDoc
pkgName' = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pkgName
isBoundsIgnoreDep :: Bool
isBoundsIgnoreDep = PackageName
pkgName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
boundsIgnoredDeps
reason :: StyleDoc
reason = if Bool
isBoundsIgnoreDep
then [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgName'
, [Char] -> StyleDoc
flow [Char]
"is an"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-dep"
, [Char] -> StyleDoc
flow [Char]
"and"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
, StyleDoc
"enabled"
]
else [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgName'
, [Char] -> StyleDoc
flow [Char]
"is not an"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-dep"
, [Char] -> StyleDoc
flow [Char]
"although"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
, StyleDoc
"enabled"
]
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
isBoundsIgnoreDep StyleDoc
reason
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBoundsIgnoreDep
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe [PackageName]
allowNewerDeps) forall a b. (a -> b) -> a -> b
$
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
False forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"although"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-deps"
, [Char] -> StyleDoc
flow [Char]
"are specified,"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
, StyleDoc
"is"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"false"
]
RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
Bool
inSnapshotCheck
if Bool
inRange
then case AddDepRes
adr of
ADRToInstall Task
task -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
Map.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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
where
isStackOpt :: Text -> Bool
isStackOpt :: Text -> Bool
isStackOpt Text
t = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
t)
[ Text
"--dependency="
, Text
"--constraint="
, Text
"--package-db="
, Text
"--libdir="
, Text
"--bindir="
, Text
"--datadir="
, Text
"--libexecdir="
, Text
"--sysconfdir"
, Text
"--docdir="
, Text
"--htmldir="
, Text
"--haddockdir="
, Text
"--enable-tests"
, Text
"--enable-benchmarks"
, Text
"--exact-configuration"
] Bool -> Bool -> Bool
|| Text
t forall a. Eq a => a -> a -> Bool
== Text
"--user"
([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
checkAndWarnForUnknownTools :: Package -> M ()
checkAndWarnForUnknownTools :: Package
-> RWST
Ctx
W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
()
checkAndWarnForUnknownTools 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [StyleDoc] -> [StyleDoc]
wWarnings = (forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> StyleDoc
toolWarningText [ToolWarning]
warnings ++) }
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 -> StyleDoc
toolWarningText :: ToolWarning -> StyleDoc
toolWarningText (ToolWarning (ExeName Text
toolName) PackageName
pkgName') = [StyleDoc] -> StyleDoc
fillSep
[ [Char] -> StyleDoc
flow [Char]
"No packages found in snapshot which provide a"
, Style -> StyleDoc -> StyleDoc
style Style
PkgComponent (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Text
toolName)
, [Char] -> StyleDoc
flow [Char]
"executable, which is a build-tool dependency of"
, Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ 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
$
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 e a. Exception e => e -> a
impureThrow forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
TaskCycleBug 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
Map.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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()