{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE ViewPatterns          #-}

-- | Construct a @Plan@ for how to build

module Stack.Build.ConstructPlan
  ( constructPlan
  ) where

import           Control.Monad.RWS.Strict hiding ( (<>) )
import           Control.Monad.State.Strict ( execState )
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import           Data.Monoid.Map ( MonoidMap(..) )
import qualified Data.Set as Set
import qualified Data.Text as T
import           Distribution.Types.BuildType ( BuildType (Configure) )
import           Distribution.Types.PackageName ( mkPackageName )
import           Generics.Deriving.Monoid ( memptydefault, mappenddefault )
import           Path ( parent )
import           RIO.Process ( findExecutable, HasProcessContext (..) )
import           Stack.Build.Cache
import           Stack.Build.Haddock
import           Stack.Build.Installed
import           Stack.Build.Source
import           Stack.Constants
import           Stack.Package
import           Stack.PackageDump
import           Stack.Prelude hiding ( loadPackage )
import           Stack.SourceMap
import           Stack.Types.Build
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.Dependency
                   ( DepValue (DepValue), DepType (AsLibrary) )
import           Stack.Types.GhcPkgId
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           Stack.Types.Version
import           System.Environment ( lookupEnv )
import           System.IO ( putStrLn )

data PackageInfo
    =
      -- | This indicates that the package is already installed, and

      -- that we shouldn't build it from source. This is only the case

      -- for global packages.

      PIOnlyInstalled InstallLocation Installed
      -- | This indicates that the package isn't installed, and we know

      -- where to find its source.

    | PIOnlySource PackageSource
      -- | This indicates that the package is installed and we know

      -- where to find its source. We may want to reinstall from source.

    | 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
        -- Always trust something in the snapshot

        InstallLocation
Snap -> InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled InstallLocation
location Installed
installed
        InstallLocation
Local -> PackageSource -> Installed -> PackageInfo
PIBoth PackageSource
ps Installed
installed

type CombinedMap = Map PackageName PackageInfo

combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap = forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
    (\PackageName
_ PackageSource
s (InstallLocation, Installed)
i -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i)
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSource -> PackageInfo
PIOnlySource)
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled))

data AddDepRes
    = ADRToInstall Task
    | ADRFound InstallLocation Installed
    deriving Int -> AddDepRes -> ShowS
[AddDepRes] -> ShowS
AddDepRes -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AddDepRes] -> ShowS
$cshowList :: [AddDepRes] -> ShowS
show :: AddDepRes -> [Char]
$cshow :: AddDepRes -> [Char]
showsPrec :: Int -> AddDepRes -> ShowS
$cshowsPrec :: Int -> AddDepRes -> ShowS
Show

data W = W
    { W -> Map PackageName (Either ConstructPlanException Task)
wFinals :: !(Map PackageName (Either ConstructPlanException Task))
    , W -> Map Text InstallLocation
wInstall :: !(Map Text InstallLocation)
    -- ^ executable to be installed, and location where the binary is placed

    , W -> Map PackageName Text
wDirty :: !(Map PackageName Text)
    -- ^ why a local package is considered dirty

    , W -> [Text] -> [Text]
wWarnings :: !([Text] -> [Text])
    -- ^ Warnings

    , W -> ParentMap
wParents :: !ParentMap
    -- ^ Which packages a given package depends on, along with the package's version

    } 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 -- TODO replace with more efficient WS stack on top of StackT

    Ctx
    W
    (Map PackageName (Either ConstructPlanException AddDepRes))
    IO

data Ctx = Ctx
    { Ctx -> BaseConfigOpts
baseConfigOpts :: !BaseConfigOpts
    , Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage    :: !(PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> M Package)
    , Ctx -> CombinedMap
combinedMap    :: !CombinedMap
    , Ctx -> EnvConfig
ctxEnvConfig   :: !EnvConfig
    , Ctx -> [PackageName]
callStack      :: ![PackageName]
    , Ctx -> Set PackageName
wanted         :: !(Set PackageName)
    , Ctx -> Set PackageName
localNames     :: !(Set PackageName)
    , Ctx -> Maybe Curator
mcurator       :: !(Maybe Curator)
    , Ctx -> Text
pathEnvVar     :: !Text
    }

instance HasPlatform Ctx
instance HasGHCVariant Ctx
instance HasLogFunc Ctx where
    logFuncL :: Lens' Ctx LogFunc
logFuncL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasRunner Ctx where
    runnerL :: Lens' Ctx Runner
runnerL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasRunner env => Lens' env Runner
runnerL
instance HasStylesUpdate Ctx where
  stylesUpdateL :: Lens' Ctx StylesUpdate
stylesUpdateL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasTerm Ctx where
  useColorL :: Lens' Ctx Bool
useColorL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Bool
useColorL
  termWidthL :: Lens' Ctx Int
termWidthL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Int
termWidthL
instance HasConfig Ctx
instance HasPantryConfig Ctx where
    pantryConfigL :: Lens' Ctx PantryConfig
pantryConfigL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasProcessContext Ctx where
    processContextL :: Lens' Ctx ProcessContext
processContextL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasBuildConfig Ctx
instance HasSourceMap Ctx where
    sourceMapL :: Lens' Ctx SourceMap
sourceMapL = forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasSourceMap env => Lens' env SourceMap
sourceMapL
instance HasCompiler Ctx where
    compilerPathsL :: SimpleGetter Ctx CompilerPaths
compilerPathsL = forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsL
instance HasEnvConfig Ctx where
    envConfigL :: Lens' Ctx EnvConfig
envConfigL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Ctx -> EnvConfig
ctxEnvConfig (\Ctx
x EnvConfig
y -> Ctx
x { ctxEnvConfig :: EnvConfig
ctxEnvConfig = EnvConfig
y })

-- | Computes a build plan. This means figuring out which build 'Task's

-- to take, and the interdependencies among the build 'Task's. In

-- particular:

--

-- 1) It determines which packages need to be built, based on the

-- transitive deps of the current targets. For local packages, this is

-- indicated by the 'lpWanted' boolean. For extra packages to build,

-- this comes from the @extraToBuild0@ argument of type @Set

-- PackageName@. These are usually packages that have been specified on

-- the commandline.

--

-- 2) It will only rebuild an upstream package if it isn't present in

-- the 'InstalledMap', or if some of its dependencies have changed.

--

-- 3) It will only rebuild a local package if its files are dirty or

-- some of its dependencies have changed.

constructPlan :: forall env. HasEnvConfig env
              => BaseConfigOpts
              -> [DumpPackage] -- ^ locally registered

              -> (PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package

              -> SourceMap
              -> InstalledMap
              -> Bool
              -> RIO env Plan
constructPlan :: forall env.
HasEnvConfig env =>
BaseConfigOpts
-> [DumpPackage]
-> (PackageLocationImmutable
    -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package)
-> SourceMap
-> InstalledMap
-> Bool
-> RIO env Plan
constructPlan BaseConfigOpts
baseConfigOpts0 [DumpPackage]
localDumpPkgs PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
loadPackage0 SourceMap
sourceMap InstalledMap
installedMap Bool
initialBuildSteps = do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Constructing the build plan"

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasBaseInDeps forall a b. (a -> b) -> a -> b
$
      forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"You are trying to upgrade/downgrade base, which is almost certainly not what you really want. Please, consider using another GHC version if you need a certain version of base, or removing base from extra-deps. See more at https://github.com/commercialhaskell/stack/issues/3940." forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

    EnvConfig
econfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
    Version
globalCabalVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Version
cpCabalVersion
    Map PackageName PackageSource
sources <- forall {s}.
(HasBuildConfig s, HasSourceMap s) =>
Version -> RIO s (Map PackageName PackageSource)
getSources Version
globalCabalVersion
    Maybe Curator
mcur <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator

    let onTarget :: PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
onTarget = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> M (Either ConstructPlanException AddDepRes)
addDep
    let inner :: RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  ()
inner = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
onTarget forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (SMTargets -> Map PackageName Target
smtTargets forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
    Text
pathEnvVar' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PATH"
    let ctx :: Ctx
ctx = EnvConfig
-> Version
-> Map PackageName PackageSource
-> Maybe Curator
-> Text
-> Ctx
mkCtx EnvConfig
econfig Version
globalCabalVersion Map PackageName PackageSource
sources Maybe Curator
mcur Text
pathEnvVar'
    ((), Map PackageName (Either ConstructPlanException AddDepRes)
m, W Map PackageName (Either ConstructPlanException Task)
efinals Map Text InstallLocation
installExes Map PackageName Text
dirtyReason [Text] -> [Text]
warnings ParentMap
parents) <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  ()
inner Ctx
ctx forall k a. Map k a
M.empty
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display) ([Text] -> [Text]
warnings [])
    let toEither :: (a, Either a b) -> Either a (a, b)
toEither (a
_, Left a
e)  = forall a b. a -> Either a b
Left a
e
        toEither (a
k, Right b
v) = forall a b. b -> Either a b
Right (a
k, b
v)
        ([ConstructPlanException]
errlibs, [(PackageName, AddDepRes)]
adrs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {b}. (a, Either a b) -> Either a (a, b)
toEither forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map PackageName (Either ConstructPlanException AddDepRes)
m
        ([ConstructPlanException]
errfinals, [(PackageName, Task)]
finals) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {b}. (a, Either a b) -> Either a (a, b)
toEither forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map PackageName (Either ConstructPlanException Task)
efinals
        errs :: [ConstructPlanException]
errs = [ConstructPlanException]
errlibs forall a. [a] -> [a] -> [a]
++ [ConstructPlanException]
errfinals
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructPlanException]
errs
        then do
            let toTask :: (a, AddDepRes) -> Maybe (a, Task)
toTask (a
_, ADRFound InstallLocation
_ Installed
_) = forall a. Maybe a
Nothing
                toTask (a
name, ADRToInstall Task
task) = forall a. a -> Maybe a
Just (a
name, Task
task)
                tasks :: Map PackageName Task
tasks = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, AddDepRes) -> Maybe (a, Task)
toTask [(PackageName, AddDepRes)]
adrs
                takeSubset :: Plan -> RIO env Plan
takeSubset =
                    case BuildOptsCLI -> BuildSubset
boptsCLIBuildSubset forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI BaseConfigOpts
baseConfigOpts0 of
                        BuildSubset
BSAll -> forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        BuildSubset
BSOnlySnapshot -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plan -> Plan
stripLocals
                        BuildSubset
BSOnlyDependencies -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PackageName -> Plan -> Plan
stripNonDeps (forall k a. Map k a -> Set k
M.keysSet forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
                        BuildSubset
BSOnlyLocals -> forall env. Plan -> RIO env Plan
errorOnSnapshot
            forall env. Plan -> RIO env Plan
takeSubset Plan
                { planTasks :: Map PackageName Task
planTasks = Map PackageName Task
tasks
                , planFinals :: Map PackageName Task
planFinals = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(PackageName, Task)]
finals
                , planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal = Map PackageName Task
-> Map PackageName Text
-> [DumpPackage]
-> Bool
-> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal Map PackageName Task
tasks Map PackageName Text
dirtyReason [DumpPackage]
localDumpPkgs Bool
initialBuildSteps
                , planInstallExes :: Map Text InstallLocation
planInstallExes =
                    if BuildOpts -> Bool
boptsInstallExes (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
baseConfigOpts0) Bool -> Bool -> Bool
||
                       BuildOpts -> Bool
boptsInstallCompilerTool (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
baseConfigOpts0)
                        then Map Text InstallLocation
installExes
                        else forall k a. Map k a
Map.empty
                }
        else do
            forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show [ConstructPlanException]
errs
            Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
            Path Abs Dir
stackRoot <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException 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
$ \GlobalPackage
gp ->
      case GlobalPackage
gp of
         ReplacedGlobalPackage [PackageName]
deps ->
           let pruned :: [PackageName]
pruned = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
inSourceMap) [PackageName]
deps
           in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
pruned then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [PackageName]
pruned
         GlobalPackage Version
_ -> forall a. Maybe a
Nothing

    inSourceMap :: PackageName -> Bool
inSourceMap PackageName
pname = PackageName
pname forall k a. Ord k => k -> Map k a -> Bool
`Map.member` SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap Bool -> Bool -> Bool
||
                        PackageName
pname forall k a. Ord k => k -> Map k a -> Bool
`Map.member` SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap

    getSources :: Version -> RIO s (Map PackageName PackageSource)
getSources Version
globalCabalVersion = do
      let loadLocalPackage' :: ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp = do
            LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage ProjectPackage
pp
            forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp }
      Map PackageName PackageSource
pPackages <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
        LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
        forall (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

-- | Throw an exception if there are any snapshot packages in the plan.

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"
        ]
    ]

-- | State to be maintained during the calculation of local packages

-- to unregister.

data UnregisterState = UnregisterState
    { UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text))
    , UnregisterState -> [DumpPackage]
usKeep :: ![DumpPackage]
    , UnregisterState -> Bool
usAnyAdded :: !Bool
    }

-- | Determine which packages to unregister based on the given tasks and

-- already registered local packages

mkUnregisterLocal :: Map PackageName Task
                  -- ^ Tasks

                  -> Map PackageName Text
                  -- ^ Reasons why packages are dirty and must be rebuilt

                  -> [DumpPackage]
                  -- ^ Local package database dump

                  -> Bool
                  -- ^ If true, we're doing a special initialBuildSteps

                  -- build - don't unregister target packages.

                  -> 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 =
    -- We'll take multiple passes through the local packages. This

    -- will allow us to detect that a package should be unregistered,

    -- as well as all packages directly or transitively depending on

    -- it.

    Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop forall k a. Map k a
Map.empty [DumpPackage]
localDumpPkgs
  where
    loop :: Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop Map GhcPkgId (PackageIdentifier, Text)
toUnregister [DumpPackage]
keep
        -- If any new packages were added to the unregister Map, we

        -- need to loop through the remaining packages again to detect

        -- if a transitive dependency is being unregistered.

        | 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)
        -- Nothing added, so we've already caught them all. Return the

        -- Map we've already calculated.

        | Bool
otherwise = UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us
      where
        -- Run the unregister checking function on all packages we

        -- currently think we'll be keeping.

        us :: UnregisterState
us = forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
MonadState UnregisterState m =>
DumpPackage -> m ()
go [DumpPackage]
keep) UnregisterState
            { usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = Map GhcPkgId (PackageIdentifier, Text)
toUnregister
            , usKeep :: [DumpPackage]
usKeep = []
            , usAnyAdded :: Bool
usAnyAdded = Bool
False
            }

    go :: DumpPackage -> m ()
go DumpPackage
dp = do
        UnregisterState
us <- forall s (m :: * -> *). MonadState s m => m s
get
        case forall {a} {b}.
Ord a =>
Map a (PackageIdentifier, b)
-> PackageIdentifier -> [a] -> Maybe Text
go' (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) PackageIdentifier
ident [GhcPkgId]
deps of
            -- Not unregistering, add it to the keep list

            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 }
            -- Unregistering, add it to the unregister Map and

            -- indicate that a package was in fact added to the

            -- unregister Map so we loop again.

            Just Text
reason -> forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us
                { usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert GhcPkgId
gid (PackageIdentifier
ident, Text
reason) (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us)
                , usAnyAdded :: Bool
usAnyAdded = Bool
True
                }
      where
        gid :: GhcPkgId
gid = DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp
        ident :: PackageIdentifier
ident = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
        deps :: [GhcPkgId]
deps = DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp

    go' :: Map a (PackageIdentifier, b)
-> PackageIdentifier -> [a] -> Maybe Text
go' Map a (PackageIdentifier, b)
toUnregister PackageIdentifier
ident [a]
deps
      -- If we're planning on running a task on it, then it must be

      -- unregistered, unless it's a target and an initial-build-steps

      -- build is being done.

      | Just Task
task <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Task
tasks
          = if Bool
initialBuildSteps Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task Bool -> Bool -> Bool
&& Task -> PackageIdentifier
taskProvides Task
task forall a. Eq a => a -> a -> Bool
== PackageIdentifier
ident
              then forall a. Maybe a
Nothing
              else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Text
dirtyReason
      -- Check if a dependency is going to be unregistered

      | (PackageIdentifier
dep, b
_):[(PackageIdentifier, b)]
_ <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a (PackageIdentifier, b)
toUnregister) [a]
deps
          = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"Dependency being unregistered: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
dep)
      -- None of the above, keep it!

      | Bool
otherwise = forall a. Maybe a
Nothing
      where
        name :: PackageName
        name :: PackageName
name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident

-- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for

-- running its tests and benchmarks.

--

-- If @isAllInOne@ is 'True', then this means that the build step will

-- also build the tests. Otherwise, this indicates that there's a cyclic

-- dependency and an additional build step needs to be done.

--

-- This will also add all the deps needed to build the tests /

-- benchmarks. If @isAllInOne@ is 'True' (the common case), then all of

-- these should have already been taken care of as part of the build

-- step.

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 -- local

                            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 }

-- | Given a 'PackageName', adds all of the build tasks to build the

-- package, if needed.

--

-- 'constructPlan' invokes this on all the target packages, setting

-- @treatAsDep'@ to False, because those packages are direct build

-- targets. 'addPackageDeps' invokes this while recursing into the

-- dependencies of a package. As such, it sets @treatAsDep'@ to True,

-- forcing this package to be marked as a dependency, even if it is

-- directly wanted. This makes sense - if we left out packages that are

-- deps, it would break the --only-dependencies build plan.

addDep :: PackageName
       -> M (Either ConstructPlanException AddDepRes)
addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)
addDep PackageName
name = do
    Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Map PackageName (Either ConstructPlanException AddDepRes)
m <- forall s (m :: * -> *). MonadState s m => m s
get
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
m of
        Just Either ConstructPlanException AddDepRes
res -> do
            forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Using cached result for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Either ConstructPlanException AddDepRes
res
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res
        Maybe (Either ConstructPlanException AddDepRes)
Nothing -> do
            Either ConstructPlanException AddDepRes
res <- if PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Ctx -> [PackageName]
callStack Ctx
ctx
                then do
                    forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Detected cycle " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Ctx -> [PackageName]
callStack Ctx
ctx)
                    forall (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
                    let mpackageInfo :: Maybe PackageInfo
mpackageInfo = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name forall a b. (a -> b) -> a -> b
$ Ctx -> CombinedMap
combinedMap Ctx
ctx
                    forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Package info for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Maybe PackageInfo
mpackageInfo
                    case Maybe PackageInfo
mpackageInfo of
                        -- TODO look up in the package index and see if there's a

                        -- recommendation available

                        Maybe PackageInfo
Nothing -> 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 (PIOnlyInstalled InstallLocation
loc Installed
installed) -> do
                            -- FIXME Slightly hacky, no flags since

                            -- they likely won't affect executable

                            -- names. This code does not feel right.

                            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
                                      -- this could happen for GHC boot libraries missing from Hackage

                                      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No latest package revision found for: " forall a. Semigroup a => a -> a -> a
<>
                                          forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", dependency callstack: " forall a. Semigroup a => a -> a -> a
<>
                                          forall a. Show a => a -> Utf8Builder
displayShow (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Ctx -> [PackageName]
callStack Ctx
ctx)
                                      forall (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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                                          PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
                            PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutablesUpstream PackageName
name RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Maybe PackageLocationImmutable)
askPkgLoc InstallLocation
loc forall k a. Map k a
Map.empty
                            forall (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
                        Just (PIOnlySource PackageSource
ps) -> do
                            PackageName
-> PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutables PackageName
name PackageSource
ps
                            PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps forall a. Maybe a
Nothing
                        Just (PIBoth PackageSource
ps Installed
installed) -> do
                            PackageName
-> PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutables PackageName
name PackageSource
ps
                            PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps (forall a. a -> Maybe a
Just Installed
installed)
            PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res

-- FIXME what's the purpose of this? Add a Haddock!

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 ()
-- Ignores ghcOptions because they don't matter for enumerating

-- executables.

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
    -- Determine which components are enabled so we know which ones to copy

    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

-- | Given a 'PackageSource' and perhaps an 'Installed' value, adds

-- build 'Task's for the package and its dependencies.

installPackage :: PackageName
               -> PackageSource
               -> Maybe Installed
               -> M (Either ConstructPlanException AddDepRes)
installPackage :: PackageName
-> PackageSource
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
minstalled = do
    Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
    case PackageSource
ps of
        PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
cp -> do
            forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: Doing all-in-one build for upstream package " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name
            Package
package <- Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage Ctx
ctx PackageLocationImmutable
pkgLoc (CommonPackage -> Map FlagName Bool
cpFlags CommonPackage
cp) (CommonPackage -> [Text]
cpGhcOptions CommonPackage
cp) (CommonPackage -> [Text]
cpCabalConfigOpts CommonPackage
cp)
            Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
True (CommonPackage -> Bool
cpHaddocks CommonPackage
cp) PackageSource
ps Package
package Maybe Installed
minstalled
        PSFilePath LocalPackage
lp -> do
            case LocalPackage -> Maybe Package
lpTestBench LocalPackage
lp of
                Maybe Package
Nothing -> do
                    forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: No test / bench component for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
" so doing an all-in-one build."
                    Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
True (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps (LocalPackage -> Package
lpPackage LocalPackage
lp) Maybe Installed
minstalled
                Just Package
tb -> do
                    -- Attempt to find a plan which performs an all-in-one

                    -- build.  Ignore the writer action + reset the state if

                    -- it fails.

                    Map PackageName (Either ConstructPlanException AddDepRes)
s <- forall s (m :: * -> *). MonadState s m => m s
get
                    Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall a b. (a -> b) -> a -> b
$ do
                        Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
tb
                        let writerFunc :: a -> a
writerFunc a
w = case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
                                Left ConstructPlanException
_ -> forall a. Monoid a => a
mempty
                                Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
_ -> a
w
                        forall (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. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
", successfully added package deps"
                          -- in curator builds we can't do all-in-one build as test/benchmark failure

                          -- could prevent library from being available to its dependencies

                          -- but when it's already available it's OK to do that

                          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
                          -- FIXME: this redundantly adds the deps (but

                          -- they'll all just get looked up in the map)

                          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
                            -- Reset the state to how it was before

                            -- attempting to find an all-in-one build

                            -- plan.

                            forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"installPackage: Before trying cyclic plan, resetting lib result map to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Map PackageName (Either ConstructPlanException AddDepRes)
s
                            forall s (m :: * -> *). MonadState s m => s -> m ()
put Map PackageName (Either ConstructPlanException AddDepRes)
s
                            -- Otherwise, fall back on building the

                            -- tests / benchmarks in a separate step.

                            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
                                -- Insert it into the map so that it's

                                -- available for addFinal.

                                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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> M AddDepRes
installPackageGivenDeps Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps

-- | Checks if we need to install the given 'Package', given the results

-- of 'addPackageDeps'. If dependencies are missing, the package is

-- dirty, or it's not installed, then it needs to be installed.

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
            }

-- | Is the build type of the package Configure

packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig Package
pkg = Package -> BuildType
packageBuildType Package
pkg forall a. Eq a => a -> a -> Bool
== BuildType
Configure

-- Update response in the lib map. If it is an error, and there's

-- already an error about cyclic dependencies, prefer the cyclic error.

updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M ()
updateLibMap :: PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
val = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Map PackageName (Either ConstructPlanException AddDepRes)
mp ->
    case (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
mp, Either ConstructPlanException AddDepRes
val) of
        (Just (Left DependencyCycleDetected{}), Left ConstructPlanException
_) -> Map PackageName (Either ConstructPlanException AddDepRes)
mp
        (Maybe (Either ConstructPlanException AddDepRes),
 Either ConstructPlanException AddDepRes)
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name Either ConstructPlanException AddDepRes
val Map PackageName (Either ConstructPlanException AddDepRes)
mp

addEllipsis :: Text -> Text
addEllipsis :: Text -> Text
addEllipsis Text
t
    | Text -> Int
T.length Text
t forall a. Ord a => a -> a -> Bool
< Int
100 = Text
t
    | Bool
otherwise = Int -> Text -> Text
T.take Int
97 Text
t forall a. Semigroup a => a -> a -> a
<> Text
"..."

-- | Given a package, recurses into all of its dependencies. The results

-- indicate which packages are missing, meaning that their 'GhcPkgId's

-- will be figured out during the build, after they've been built. The

-- 2nd part of the tuple result indicates the packages that are already

-- installed which will be used.

--

-- The 3rd part of the tuple is an 'InstallLocation'. If it is 'Local',

-- then the parent package must be installed locally. Otherwise, if it

-- is 'Snap', then it can either be installed locally or in the

-- snapshot.

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
                            -- ultimately we won't show any

                            -- information on this to the user, we'll

                            -- allow the dependency failures alone to

                            -- display to avoid spamming the user too

                            -- much

                            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_ :: Text -> m ()
warn_ Text
reason =
                                forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = (Text
msgforall a. a -> [a] -> [a]
:) }
                              where
                                msg :: Text
msg = [Text] -> Text
T.concat
                                    [ Text
"WARNING: Ignoring "
                                    , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
                                    , Text
"'s bounds on "
                                    , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
depname
                                    , Text
" ("
                                    , VersionRange -> Text
versionRangeText VersionRange
range
                                    , Text
"); using "
                                    , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)
                                    , Text
".\nReason: "
                                    , Text
reason
                                    , Text
"."
                                    ]
                        Bool
allowNewer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
                        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
                                -- We ignore dependency information for packages in a snapshot

                                Bool
x <- PackageName
-> Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
inSnapshot (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
                                Bool
y <- PackageName
-> Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
inSnapshot PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)
                                if Bool
x Bool -> Bool -> Bool
&& Bool
y
                                    then do
                                        forall {m :: * -> *}. MonadWriter W m => Text -> m ()
warn_ Text
"trusting snapshot over Cabal file dependency information"
                                        forall (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 do
                                forall {m :: * -> *}. MonadWriter W m => Text -> m ()
warn_ Text
"allow-newer enabled"
                                case Maybe [PackageName]
allowNewerDeps of
                                    Maybe [PackageName]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                                    Just [PackageName]
boundsIgnoredDeps ->
                                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
boundsIgnoredDeps
                            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 => Text -> m ()
warn_ Text
"allow-newer-deps are specified but allow-newer isn't enabled"
                                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
        -- Note that the Monoid for 'InstallLocation' means that if any

        -- is 'Local', the result is 'Local', indicating that the parent

        -- package must be installed locally. Otherwise the result is

        -- 'Snap', indicating that the parent can either be installed

        -- locally or in the snapshot.

        ([], [(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
    -- Update the parents map, for later use in plan construction errors

    -- - see 'getShortestDepsPath'.

    addParent :: PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range Maybe Version
mversion = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wParents :: ParentMap
wParents = forall k a. Map k a -> MonoidMap k a
MonoidMap forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton PackageName
depname (First Version, [(PackageIdentifier, VersionRange)])
val }
      where
        val :: (First Version, [(PackageIdentifier, VersionRange)])
val = (forall a. Maybe a -> First a
First Maybe Version
mversion, [(Package -> PackageIdentifier
packageIdentifier Package
package, VersionRange
range)])

    adrHasLibrary :: AddDepRes -> Bool
    adrHasLibrary :: AddDepRes -> Bool
adrHasLibrary (ADRToInstall Task
task) = Task -> Bool
taskHasLibrary Task
task
    adrHasLibrary (ADRFound InstallLocation
_ Library{}) = Bool
True
    adrHasLibrary (ADRFound InstallLocation
_ Executable{}) = Bool
False

    taskHasLibrary :: Task -> Bool
    taskHasLibrary :: Task -> Bool
taskHasLibrary Task
task =
      case Task -> TaskType
taskType Task
task of
        TTLocalMutable LocalPackage
lp -> Package -> Bool
packageHasLibrary forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
        TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package -> Bool
packageHasLibrary Package
p

    -- make sure we consider internal libraries as libraries too

    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) -- should be Local i.e. mutable always

            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

        -- GHC options which affect build results and therefore should always

        -- force a rebuild

        --

        -- For the most part, we only care about options generated by Stack

        -- itself

        isKeeper :: Text -> Bool
isKeeper = (forall a. Eq a => a -> a -> Bool
== Text
"-fhpc") -- more to be added later


    userOpts :: ConfigCache -> [Text]
userOpts = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isStackOpt)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Config -> Bool
configRebuildGhcOptions Config
config
                   then forall a. a -> a
id
                   else [Text] -> [Text]
stripGhcOptions)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(ConfigureOpts [[Char]]
x [[Char]]
y) -> [[Char]]
x forall a. [a] -> [a] -> [a]
++ [[Char]]
y)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigCache -> ConfigureOpts
configCacheOpts

    ([Text]
oldOpts, [Text]
newOpts) = forall {a}. Eq a => [a] -> [a] -> ([a], [a])
removeMatching (ConfigCache -> [Text]
userOpts ConfigCache
old) (ConfigCache -> [Text]
userOpts ConfigCache
new)

    removeMatching :: [a] -> [a] -> ([a], [a])
removeMatching (a
x:[a]
xs) (a
y:[a]
ys)
        | a
x forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a] -> ([a], [a])
removeMatching [a]
xs [a]
ys
    removeMatching [a]
xs [a]
ys = ([a]
xs, [a]
ys)

    newComponents :: Set ByteString
newComponents = ConfigCache -> Set ByteString
configCacheComponents ConfigCache
new forall {a}. Ord a => Set a -> Set a -> Set a
`Set.difference` ConfigCache -> Set ByteString
configCacheComponents ConfigCache
old

    pkgSrcName :: CachePkgSrc -> Text
pkgSrcName (CacheSrcLocal [Char]
fp) = [Char] -> Text
T.pack [Char]
fp
    pkgSrcName CachePkgSrc
CacheSrcUpstream = Text
"upstream source"

psForceDirty :: PackageSource -> Bool
psForceDirty :: PackageSource -> Bool
psForceDirty (PSFilePath LocalPackage
lp) = LocalPackage -> Bool
lpForceDirty LocalPackage
lp
psForceDirty PSRemote{} = Bool
False

psDirty
  :: (MonadIO m, HasEnvConfig env, MonadReader env m)
  => PackageSource
  -> m (Maybe (Set FilePath))
psDirty :: forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set [Char]))
psDirty (PSFilePath LocalPackage
lp) = forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith forall a b. (a -> b) -> a -> b
$ LocalPackage -> MemoizedWith EnvConfig (Maybe (Set [Char]))
lpDirtyFiles LocalPackage
lp
psDirty PSRemote {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing -- files never change in a remote package


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

-- | Get all of the dependencies for a given package, including build

-- tool dependencies.

checkAndWarnForUnknownTools :: Package -> M ()
checkAndWarnForUnknownTools :: Package
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
checkAndWarnForUnknownTools Package
p = do
    -- Check whether the tool is on the PATH before warning about it.

    [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 :: [Text] -> [Text]
wWarnings = (forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> Text
toolWarningText [ToolWarning]
warnings forall a. [a] -> [a] -> [a]
++) }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Warn about tools in the snapshot definition. States the tool name

-- expected and the package name using it.

data ToolWarning = ToolWarning ExeName PackageName
  deriving Int -> ToolWarning -> ShowS
[ToolWarning] -> ShowS
ToolWarning -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ToolWarning] -> ShowS
$cshowList :: [ToolWarning] -> ShowS
show :: ToolWarning -> [Char]
$cshow :: ToolWarning -> [Char]
showsPrec :: Int -> ToolWarning -> ShowS
$cshowsPrec :: Int -> ToolWarning -> ShowS
Show

toolWarningText :: ToolWarning -> Text
toolWarningText :: ToolWarning -> Text
toolWarningText (ToolWarning (ExeName Text
toolName) PackageName
pkgName') =
    Text
"No packages found in snapshot which provide a " forall a. Semigroup a => a -> a -> a
<>
    [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Text
toolName) forall a. Semigroup a => a -> a -> a
<>
    Text
" executable, which is a build-tool dependency of " forall a. Semigroup a => a -> a -> a
<>
    [Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
pkgName')

-- | Strip out anything from the @Plan@ intended for the local database

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 -- TODO maybe don't disable this?

    }
  where
    checkTask :: Task -> Bool
checkTask Task
task = Task -> PackageIdentifier
taskProvides Task
task forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageIdentifier
missingForDeps
    providesDep :: Task -> Bool
providesDep Task
task = PackageIdentifier -> PackageName
pkgName (Task -> PackageIdentifier
taskProvides Task
task) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
deps
    missing :: Map PackageIdentifier (Set PackageIdentifier)
missing = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Task -> PackageIdentifier
taskProvides forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TaskConfigOpts -> Set PackageIdentifier
tcoMissing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> TaskConfigOpts
taskConfigOpts) forall a b. (a -> b) -> a -> b
$
              forall k a. Map k a -> [a]
Map.elems (Plan -> Map PackageName Task
planTasks Plan
plan)
    missingForDeps :: Set PackageIdentifier
missingForDeps = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan) forall a b. (a -> b) -> a -> b
$ \Task
task ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Task -> Bool
providesDep Task
task) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
MonadState (Set PackageIdentifier) m =>
[PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing forall a. Monoid a => a
mempty (Task -> PackageIdentifier
taskProvides Task
task)

    collectMissing :: [PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
dependents PackageIdentifier
pid = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
pid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageIdentifier]
dependents) forall a b. (a -> b) -> a -> b
$ forall 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
M.lookup PackageIdentifier
pid Map PackageIdentifier (Set PackageIdentifier)
missing)

-- | Is the given package/version combo defined in the snapshot or in the global database?

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
            -- OnlyInstalled occurs for global database

            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

-- TODO: Consider intersecting version ranges for multiple deps on a

-- package.  This is why VersionRange is in the parent map.



-- Switch this to 'True' to enable some debugging putStrLn in this module

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 ()