{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}

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

module Stack.Build.ConstructPlan
  ( constructPlan
  ) where

import           Control.Monad.RWS.Strict
                   ( RWST, get, modify, modify', pass, put, runRWST, tell )
import           Control.Monad.Trans.Maybe ( MaybeT (..) )
import qualified Data.List as L
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import           Data.Monoid.Map ( MonoidMap(..) )
import qualified Data.Set as Set
import qualified Data.Text as T
import           Distribution.Types.BuildType ( BuildType (Configure) )
import           Distribution.Types.PackageName ( mkPackageName )
import           Generics.Deriving.Monoid ( memptydefault, mappenddefault )
import           Path ( parent )
import           RIO.Process ( HasProcessContext (..), findExecutable )
import           RIO.State ( State, execState )
import           Stack.Build.Cache ( tryGetFlagCache )
import           Stack.Build.Haddock ( shouldHaddockDeps )
import           Stack.Build.Source ( loadLocalPackage )
import           Stack.Constants ( compilerOptionsCabalFlag )
import           Stack.Package ( applyForceCustomBuild )
import           Stack.Prelude hiding ( loadPackage )
import           Stack.SourceMap ( getPLIVersion, mkProjectPackage )
import           Stack.Types.Build
                   ( CachePkgSrc (..), ConfigCache (..), Plan (..), Task (..)
                   , TaskConfigOpts (..), TaskType (..)
                   , installLocationIsMutable, taskIsTarget, taskLocation
                   , taskTargetIsMutable, toCachePkgSrc
                   )
import           Stack.Types.Build.Exception
                   ( BadDependency (..), BuildException (..)
                   , BuildPrettyException (..), ConstructPlanException (..)
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import           Stack.Types.BuildOpts
                   ( BuildOpts (..), BuildOptsCLI (..), BuildSubset (..) )
import           Stack.Types.Compiler ( WhichCompiler (..) )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..), stackRootL )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..), configureOpts )
import           Stack.Types.Curator ( Curator (..) )
import           Stack.Types.Dependency
                   ( DepValue (DepValue), DepType (AsLibrary) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) )
import           Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings )
import           Stack.Types.GHCVariant ( HasGHCVariant (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.IsMutable ( IsMutable (..) )
import           Stack.Types.NamedComponent ( exeComponents, renderComponent )
import           Stack.Types.Package
                   ( ExeName (..), InstallLocation (..), Installed (..)
                   , InstalledMap, LocalPackage (..), Package (..)
                   , PackageLibraries (..), PackageSource (..), installedVersion
                   , packageIdentifier, psVersion, runMemoizedWith
                   )
import           Stack.Types.ParentMap ( ParentMap )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.ProjectConfig ( isPCGlobalProject )
import           Stack.Types.Runner ( HasRunner (..), globalOptsL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), FromSnapshot (..)
                   , GlobalPackage (..), SMTargets (..), SourceMap (..)
                   )
import           Stack.Types.Version
                   ( latestApplicableVersion, versionRangeText, withinRange )
import           System.Environment ( lookupEnv )

data PackageInfo
  = PIOnlyInstalled InstallLocation Installed
    -- ^ 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.

  | PIOnlySource PackageSource
    -- ^ This indicates that the package isn't installed, and we know where to

    -- find its source.

  | PIBoth PackageSource Installed
    -- ^ This indicates that the package is installed and we know where to find

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

  deriving Int -> PackageInfo -> ShowS
[PackageInfo] -> ShowS
PackageInfo -> [Char]
(Int -> PackageInfo -> ShowS)
-> (PackageInfo -> [Char])
-> ([PackageInfo] -> ShowS)
-> Show PackageInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackageInfo -> ShowS
showsPrec :: Int -> PackageInfo -> ShowS
$cshow :: PackageInfo -> [Char]
show :: PackageInfo -> [Char]
$cshowList :: [PackageInfo] -> ShowS
showList :: [PackageInfo] -> ShowS
Show

combineSourceInstalled :: PackageSource
                       -> (InstallLocation, Installed)
                       -> PackageInfo
combineSourceInstalled :: PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
ps (InstallLocation
location, Installed
installed) =
  Bool -> PackageInfo -> PackageInfo
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageSource -> Version
psVersion PackageSource
ps Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Installed -> Version
installedVersion Installed
installed) (PackageInfo -> PackageInfo) -> PackageInfo -> PackageInfo
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 = SimpleWhenMissing PackageName PackageSource PackageInfo
-> SimpleWhenMissing
     PackageName (InstallLocation, Installed) PackageInfo
-> SimpleWhenMatched
     PackageName PackageSource (InstallLocation, Installed) PackageInfo
-> Map PackageName PackageSource
-> InstalledMap
-> CombinedMap
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
  ((PackageName -> PackageSource -> PackageInfo)
-> SimpleWhenMissing PackageName PackageSource PackageInfo
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ PackageSource
s -> PackageSource -> PackageInfo
PIOnlySource PackageSource
s))
  ((PackageName -> (InstallLocation, Installed) -> PackageInfo)
-> SimpleWhenMissing
     PackageName (InstallLocation, Installed) PackageInfo
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ (InstallLocation, Installed)
i -> (InstallLocation -> Installed -> PackageInfo)
-> (InstallLocation, Installed) -> PackageInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled (InstallLocation, Installed)
i))
  ((PackageName
 -> PackageSource -> (InstallLocation, Installed) -> PackageInfo)
-> SimpleWhenMatched
     PackageName PackageSource (InstallLocation, Installed) PackageInfo
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\PackageName
_ PackageSource
s (InstallLocation, Installed)
i -> PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i))

data AddDepRes
  = ADRToInstall Task
  | ADRFound InstallLocation Installed
  deriving Int -> AddDepRes -> ShowS
[AddDepRes] -> ShowS
AddDepRes -> [Char]
(Int -> AddDepRes -> ShowS)
-> (AddDepRes -> [Char])
-> ([AddDepRes] -> ShowS)
-> Show AddDepRes
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddDepRes -> ShowS
showsPrec :: Int -> AddDepRes -> ShowS
$cshow :: AddDepRes -> [Char]
show :: AddDepRes -> [Char]
$cshowList :: [AddDepRes] -> ShowS
showList :: [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 -> [StyleDoc] -> [StyleDoc]
wWarnings :: !([StyleDoc] -> [StyleDoc])
    -- ^ Warnings

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

    -- version

  }
  deriving (forall x. W -> Rep W x) -> (forall x. Rep W x -> W) -> Generic W
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
$cfrom :: forall x. W -> Rep W x
from :: forall x. W -> Rep W x
$cto :: forall x. Rep W x -> W
to :: forall x. Rep W x -> W
Generic

instance Semigroup W where
  <> :: W -> W -> W
(<>) = W -> W -> W
forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault

instance Monoid W where
  mempty :: W
mempty = W
forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
  mappend :: W -> W -> W
mappend = W -> W -> W
forall a. Semigroup a => a -> a -> a
(<>)

type M = RWST -- TODO replace with more efficient WS stack on top of (RIO Ctx).

  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  -- ^ Library map

  IO

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

instance HasPlatform Ctx where
  platformL :: Lens' Ctx Platform
platformL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((Platform -> f Platform) -> Config -> f Config)
-> (Platform -> f Platform)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Platform -> f Platform) -> Config -> f Config
forall env. HasPlatform env => Lens' env Platform
Lens' Config Platform
platformL
  {-# INLINE platformL #-}
  platformVariantL :: Lens' Ctx PlatformVariant
platformVariantL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((PlatformVariant -> f PlatformVariant) -> Config -> f Config)
-> (PlatformVariant -> f PlatformVariant)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PlatformVariant -> f PlatformVariant) -> Config -> f Config
forall env. HasPlatform env => Lens' env PlatformVariant
Lens' Config PlatformVariant
platformVariantL
  {-# INLINE platformVariantL #-}

instance HasGHCVariant Ctx where
  ghcVariantL :: SimpleGetter Ctx GHCVariant
ghcVariantL = (Config -> Const r Config) -> Ctx -> Const r Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> Const r Config) -> Ctx -> Const r Ctx)
-> ((GHCVariant -> Const r GHCVariant) -> Config -> Const r Config)
-> (GHCVariant -> Const r GHCVariant)
-> Ctx
-> Const r Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GHCVariant -> Const r GHCVariant) -> Config -> Const r Config
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter Config GHCVariant
ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasLogFunc Ctx where
  logFuncL :: Lens' Ctx LogFunc
logFuncL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((LogFunc -> f LogFunc) -> Config -> f Config)
-> (LogFunc -> f LogFunc)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> Config -> f Config
forall env. HasLogFunc env => Lens' env LogFunc
Lens' Config LogFunc
logFuncL

instance HasRunner Ctx where
  runnerL :: Lens' Ctx Runner
runnerL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((Runner -> f Runner) -> Config -> f Config)
-> (Runner -> f Runner)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> Config -> f Config
forall env. HasRunner env => Lens' env Runner
Lens' Config Runner
runnerL

instance HasStylesUpdate Ctx where
  stylesUpdateL :: Lens' Ctx StylesUpdate
stylesUpdateL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
Lens' Ctx Runner
runnerL((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((StylesUpdate -> f StylesUpdate) -> Runner -> f Runner)
-> (StylesUpdate -> f StylesUpdate)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> Runner -> f Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Runner StylesUpdate
stylesUpdateL

instance HasTerm Ctx where
  useColorL :: Lens' Ctx Bool
useColorL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
Lens' Ctx Runner
runnerL((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((Bool -> f Bool) -> Runner -> f Runner)
-> (Bool -> f Bool)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Bool
Lens' Runner Bool
useColorL
  termWidthL :: Lens' Ctx Int
termWidthL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
Lens' Ctx Runner
runnerL((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((Int -> f Int) -> Runner -> f Runner)
-> (Int -> f Int)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Int
Lens' Runner Int
termWidthL

instance HasConfig Ctx where
  configL :: Lens' Ctx Config
configL = (BuildConfig -> f BuildConfig) -> Ctx -> f Ctx
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' Ctx BuildConfig
buildConfigL((BuildConfig -> f BuildConfig) -> Ctx -> f Ctx)
-> ((Config -> f Config) -> BuildConfig -> f BuildConfig)
-> (Config -> f Config)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Config)
-> (BuildConfig -> Config -> BuildConfig)
-> Lens BuildConfig BuildConfig Config Config
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BuildConfig -> Config
bcConfig (\BuildConfig
x Config
y -> BuildConfig
x { bcConfig :: Config
bcConfig = Config
y })
  {-# INLINE configL #-}

instance HasPantryConfig Ctx where
  pantryConfigL :: Lens' Ctx PantryConfig
pantryConfigL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((PantryConfig -> f PantryConfig) -> Config -> f Config)
-> (PantryConfig -> f PantryConfig)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> Config -> f Config
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' Config PantryConfig
pantryConfigL

instance HasProcessContext Ctx where
  processContextL :: Lens' Ctx ProcessContext
processContextL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((ProcessContext -> f ProcessContext) -> Config -> f Config)
-> (ProcessContext -> f ProcessContext)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> Config -> f Config
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' Config ProcessContext
processContextL

instance HasBuildConfig Ctx where
  buildConfigL :: Lens' Ctx BuildConfig
buildConfigL = (EnvConfig -> f EnvConfig) -> Ctx -> f Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL((EnvConfig -> f EnvConfig) -> Ctx -> f Ctx)
-> ((BuildConfig -> f BuildConfig) -> EnvConfig -> f EnvConfig)
-> (BuildConfig -> f BuildConfig)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> BuildConfig)
-> (EnvConfig -> BuildConfig -> EnvConfig)
-> Lens EnvConfig EnvConfig BuildConfig BuildConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    EnvConfig -> BuildConfig
envConfigBuildConfig
    (\EnvConfig
x BuildConfig
y -> EnvConfig
x { envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig
y })

instance HasSourceMap Ctx where
  sourceMapL :: Lens' Ctx SourceMap
sourceMapL = (EnvConfig -> f EnvConfig) -> Ctx -> f Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL((EnvConfig -> f EnvConfig) -> Ctx -> f Ctx)
-> ((SourceMap -> f SourceMap) -> EnvConfig -> f EnvConfig)
-> (SourceMap -> f SourceMap)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SourceMap -> f SourceMap) -> EnvConfig -> f EnvConfig
forall env. HasSourceMap env => Lens' env SourceMap
Lens' EnvConfig SourceMap
sourceMapL

instance HasCompiler Ctx where
  compilerPathsL :: SimpleGetter Ctx CompilerPaths
compilerPathsL = (EnvConfig -> Const r EnvConfig) -> Ctx -> Const r Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL((EnvConfig -> Const r EnvConfig) -> Ctx -> Const r Ctx)
-> ((CompilerPaths -> Const r CompilerPaths)
    -> EnvConfig -> Const r EnvConfig)
-> (CompilerPaths -> Const r CompilerPaths)
-> Ctx
-> Const r Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CompilerPaths -> Const r CompilerPaths)
-> EnvConfig -> Const r EnvConfig
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter EnvConfig CompilerPaths
compilerPathsL

instance HasEnvConfig Ctx where
  envConfigL :: Lens' Ctx EnvConfig
envConfigL = (Ctx -> EnvConfig)
-> (Ctx -> EnvConfig -> Ctx) -> Lens' Ctx EnvConfig
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 command line.

--

-- 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
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Constructing the build plan"

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasBaseInDeps (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ [Char] -> StyleDoc
flow [Char]
"You are trying to upgrade or downgrade the"
           , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
           , [Char] -> StyleDoc
flow [Char]
"package, which is almost certainly not what you really \
                  \want. Please, consider using another GHC version if you \
                  \need a certain version of"
           , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
           , [Char] -> StyleDoc
flow [Char]
"or removing"
           , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
           , [Char] -> StyleDoc
flow [Char]
"as an"
           , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
           , [Char] -> StyleDoc
flow [Char]
"For further information, see"
           , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/3940" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  EnvConfig
econfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL
  Version
globalCabalVersion <- Getting Version env Version -> RIO env Version
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Version env Version -> RIO env Version)
-> Getting Version env Version -> RIO env Version
forall a b. (a -> b) -> a -> b
$ Getting Version env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsLGetting Version env CompilerPaths
-> ((Version -> Const Version Version)
    -> CompilerPaths -> Const Version CompilerPaths)
-> Getting Version env Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CompilerPaths -> Version) -> SimpleGetter CompilerPaths Version
forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Version
cpCabalVersion
  Map PackageName PackageSource
sources <- Version -> RIO env (Map PackageName PackageSource)
getSources Version
globalCabalVersion
  Maybe Curator
mcur <- Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe Curator) env (Maybe Curator)
 -> RIO env (Maybe Curator))
-> Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL((BuildConfig -> Const (Maybe Curator) BuildConfig)
 -> env -> Const (Maybe Curator) env)
-> ((Maybe Curator -> Const (Maybe Curator) (Maybe Curator))
    -> BuildConfig -> Const (Maybe Curator) BuildConfig)
-> Getting (Maybe Curator) env (Maybe Curator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Maybe Curator)
-> SimpleGetter BuildConfig (Maybe Curator)
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 = RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   (Either ConstructPlanException AddDepRes)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> (PackageName
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Either ConstructPlanException AddDepRes))
-> PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep
  let inner :: RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  ()
inner = (PackageName
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> [PackageName]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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 ([PackageName]
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> [PackageName]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ Map PackageName Target -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (SMTargets -> Map PackageName Target
smtTargets (SMTargets -> Map PackageName Target)
-> SMTargets -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
  Text
pathEnvVar' <- IO Text -> RIO env Text
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> RIO env Text) -> IO Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ Text -> ([Char] -> Text) -> Maybe [Char] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty [Char] -> Text
T.pack (Maybe [Char] -> Text) -> IO (Maybe [Char]) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PATH"
  let ctx :: Ctx
ctx = EnvConfig
-> Version
-> Map PackageName PackageSource
-> Maybe Curator
-> Text
-> Ctx
mkCtx EnvConfig
econfig Version
globalCabalVersion Map PackageName PackageSource
sources Maybe Curator
mcur Text
pathEnvVar'
  ((), Map PackageName (Either ConstructPlanException AddDepRes)
m, W Map PackageName (Either ConstructPlanException Task)
efinals Map Text InstallLocation
installExes Map PackageName Text
dirtyReason [StyleDoc] -> [StyleDoc]
warnings ParentMap
parents) <-
    IO
  ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
-> RIO
     env
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
 -> RIO
      env
      ((), Map PackageName (Either ConstructPlanException AddDepRes), W))
-> IO
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
-> RIO
     env
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
forall a b. (a -> b) -> a -> b
$ RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  ()
-> Ctx
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> IO
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
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 Map PackageName (Either ConstructPlanException AddDepRes)
forall k a. Map k a
Map.empty
  (StyleDoc -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn ([StyleDoc] -> [StyleDoc]
warnings [])
  let toEither :: (a, Either a b) -> Either a (a, b)
toEither (a
_, Left a
e)  = a -> Either a (a, b)
forall a b. a -> Either a b
Left a
e
      toEither (a
k, Right b
v) = (a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
k, b
v)
      ([ConstructPlanException]
errlibs, [(PackageName, AddDepRes)]
adrs) = [Either ConstructPlanException (PackageName, AddDepRes)]
-> ([ConstructPlanException], [(PackageName, AddDepRes)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ConstructPlanException (PackageName, AddDepRes)]
 -> ([ConstructPlanException], [(PackageName, AddDepRes)]))
-> [Either ConstructPlanException (PackageName, AddDepRes)]
-> ([ConstructPlanException], [(PackageName, AddDepRes)])
forall a b. (a -> b) -> a -> b
$ ((PackageName, Either ConstructPlanException AddDepRes)
 -> Either ConstructPlanException (PackageName, AddDepRes))
-> [(PackageName, Either ConstructPlanException AddDepRes)]
-> [Either ConstructPlanException (PackageName, AddDepRes)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Either ConstructPlanException AddDepRes)
-> Either ConstructPlanException (PackageName, AddDepRes)
forall {a} {a} {b}. (a, Either a b) -> Either a (a, b)
toEither ([(PackageName, Either ConstructPlanException AddDepRes)]
 -> [Either ConstructPlanException (PackageName, AddDepRes)])
-> [(PackageName, Either ConstructPlanException AddDepRes)]
-> [Either ConstructPlanException (PackageName, AddDepRes)]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Either ConstructPlanException AddDepRes)
-> [(PackageName, Either ConstructPlanException AddDepRes)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Either ConstructPlanException AddDepRes)
m
      ([ConstructPlanException]
errfinals, [(PackageName, Task)]
finals) = [Either ConstructPlanException (PackageName, Task)]
-> ([ConstructPlanException], [(PackageName, Task)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ConstructPlanException (PackageName, Task)]
 -> ([ConstructPlanException], [(PackageName, Task)]))
-> [Either ConstructPlanException (PackageName, Task)]
-> ([ConstructPlanException], [(PackageName, Task)])
forall a b. (a -> b) -> a -> b
$ ((PackageName, Either ConstructPlanException Task)
 -> Either ConstructPlanException (PackageName, Task))
-> [(PackageName, Either ConstructPlanException Task)]
-> [Either ConstructPlanException (PackageName, Task)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Either ConstructPlanException Task)
-> Either ConstructPlanException (PackageName, Task)
forall {a} {a} {b}. (a, Either a b) -> Either a (a, b)
toEither ([(PackageName, Either ConstructPlanException Task)]
 -> [Either ConstructPlanException (PackageName, Task)])
-> [(PackageName, Either ConstructPlanException Task)]
-> [Either ConstructPlanException (PackageName, Task)]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Either ConstructPlanException Task)
-> [(PackageName, Either ConstructPlanException Task)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Either ConstructPlanException Task)
efinals
      errs :: [ConstructPlanException]
errs = [ConstructPlanException]
errlibs [ConstructPlanException]
-> [ConstructPlanException] -> [ConstructPlanException]
forall a. [a] -> [a] -> [a]
++ [ConstructPlanException]
errfinals
  if [ConstructPlanException] -> Bool
forall a. [a] -> Bool
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
_) = Maybe (a, Task)
forall a. Maybe a
Nothing
          toTask (a
name, ADRToInstall Task
task) = (a, Task) -> Maybe (a, Task)
forall a. a -> Maybe a
Just (a
name, Task
task)
          tasks :: Map PackageName Task
tasks = [(PackageName, Task)] -> Map PackageName Task
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, Task)] -> Map PackageName Task)
-> [(PackageName, Task)] -> Map PackageName Task
forall a b. (a -> b) -> a -> b
$ ((PackageName, AddDepRes) -> Maybe (PackageName, Task))
-> [(PackageName, AddDepRes)] -> [(PackageName, Task)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName, AddDepRes) -> Maybe (PackageName, Task)
forall {a}. (a, AddDepRes) -> Maybe (a, Task)
toTask [(PackageName, AddDepRes)]
adrs
          takeSubset :: Plan -> RIO env Plan
takeSubset =
            case BuildOptsCLI -> BuildSubset
boptsCLIBuildSubset (BuildOptsCLI -> BuildSubset) -> BuildOptsCLI -> BuildSubset
forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI BaseConfigOpts
baseConfigOpts0 of
              BuildSubset
BSAll -> Plan -> RIO env Plan
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              BuildSubset
BSOnlySnapshot -> Plan -> RIO env Plan
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Plan -> RIO env Plan) -> (Plan -> Plan) -> Plan -> RIO env Plan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plan -> Plan
stripLocals
              BuildSubset
BSOnlyDependencies ->
                Plan -> RIO env Plan
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Plan -> RIO env Plan) -> (Plan -> Plan) -> Plan -> RIO env Plan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PackageName -> Plan -> Plan
stripNonDeps (Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName DepPackage -> Set PackageName)
-> Map PackageName DepPackage -> Set PackageName
forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
              BuildSubset
BSOnlyLocals -> Plan -> RIO env Plan
forall env. Plan -> RIO env Plan
errorOnSnapshot
      Plan -> RIO env Plan
forall env. Plan -> RIO env Plan
takeSubset Plan
        { planTasks :: Map PackageName Task
planTasks = Map PackageName Task
tasks
        , planFinals :: Map PackageName Task
planFinals = [(PackageName, Task)] -> Map PackageName Task
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, Task)]
finals
        , planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal =
            Map PackageName Task
-> Map PackageName Text
-> [DumpPackage]
-> Bool
-> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal Map PackageName Task
tasks Map PackageName Text
dirtyReason [DumpPackage]
localDumpPkgs Bool
initialBuildSteps
        , planInstallExes :: Map Text InstallLocation
planInstallExes =
            if BuildOpts -> Bool
boptsInstallExes (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
baseConfigOpts0) Bool -> Bool -> Bool
||
               BuildOpts -> Bool
boptsInstallCompilerTool (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
baseConfigOpts0)
                then Map Text InstallLocation
installExes
                else Map Text InstallLocation
forall k a. Map k a
Map.empty
        }
    else do
      Path Abs File
stackYaml <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
Lens' env (Path Abs File)
stackYamlL
      Path Abs Dir
stackRoot <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' env (Path Abs Dir)
stackRootL
      Bool
isImplicitGlobal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> env -> Const Bool env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const Bool Config) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to (ProjectConfig (Project, Path Abs File) -> Bool
forall a. ProjectConfig a -> Bool
isPCGlobalProject (ProjectConfig (Project, Path Abs File) -> Bool)
-> (Config -> ProjectConfig (Project, Path Abs File))
-> Config
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> ProjectConfig (Project, Path Abs File)
configProject)
      BuildPrettyException -> RIO env Plan
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (BuildPrettyException -> RIO env Plan)
-> BuildPrettyException -> RIO env Plan
forall a b. (a -> b) -> a -> b
$ [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> Bool
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> BuildPrettyException
ConstructPlanFailed
        [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot Bool
isImplicitGlobal ParentMap
parents (Ctx -> Set PackageName
wanted Ctx
ctx) Map PackageName [PackageName]
prunedGlobalDeps
 where
  hasBaseInDeps :: Bool
hasBaseInDeps = PackageName -> Map PackageName DepPackage -> Bool
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 -> EnvConfig -> RIO EnvConfig Package -> M Package
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
econfig (RIO EnvConfig Package -> M Package)
-> RIO EnvConfig Package -> M Package
forall a b. (a -> b) -> a -> b
$
        Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion (Package -> Package)
-> RIO EnvConfig Package -> RIO EnvConfig Package
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 = Map PackageName Target -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMTargets -> Map PackageName Target
smtTargets (SMTargets -> Map PackageName Target)
-> SMTargets -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
    , localNames :: Set PackageName
localNames = Map PackageName ProjectPackage -> Set PackageName
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 = ((GlobalPackage -> Maybe [PackageName])
 -> Map PackageName GlobalPackage -> Map PackageName [PackageName])
-> Map PackageName GlobalPackage
-> (GlobalPackage -> Maybe [PackageName])
-> Map PackageName [PackageName]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GlobalPackage -> Maybe [PackageName])
-> Map PackageName GlobalPackage -> Map PackageName [PackageName]
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap) ((GlobalPackage -> Maybe [PackageName])
 -> Map PackageName [PackageName])
-> (GlobalPackage -> Maybe [PackageName])
-> Map PackageName [PackageName]
forall a b. (a -> b) -> a -> b
$
    \case
      ReplacedGlobalPackage [PackageName]
deps ->
        let pruned :: [PackageName]
pruned = (PackageName -> Bool) -> [PackageName] -> [PackageName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PackageName -> Bool) -> PackageName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
inSourceMap) [PackageName]
deps
        in  if [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
pruned then Maybe [PackageName]
forall a. Maybe a
Nothing else [PackageName] -> Maybe [PackageName]
forall a. a -> Maybe a
Just [PackageName]
pruned
      GlobalPackage Version
_ -> Maybe [PackageName]
forall a. Maybe a
Nothing

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

  getSources :: Version -> RIO env (Map PackageName PackageSource)
  getSources :: Version -> RIO env (Map PackageName PackageSource)
getSources Version
globalCabalVersion = do
    let loadLocalPackage' :: ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp = do
          LocalPackage
lp <- ProjectPackage -> RIO env LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage ProjectPackage
pp
          let lpPackage' :: Package
lpPackage' =
                Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion (Package -> Package) -> Package -> Package
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
          LocalPackage -> RIO env LocalPackage
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Package
lpPackage' }
    Map PackageName PackageSource
pPackages <- Map PackageName ProjectPackage
-> (ProjectPackage -> RIO env PackageSource)
-> RIO env (Map PackageName PackageSource)
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) ((ProjectPackage -> RIO env PackageSource)
 -> RIO env (Map PackageName PackageSource))
-> (ProjectPackage -> RIO env PackageSource)
-> RIO env (Map PackageName PackageSource)
forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
      LocalPackage
lp <- ProjectPackage -> RIO env LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
      PackageSource -> RIO env PackageSource
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageSource -> RIO env PackageSource)
-> PackageSource -> RIO env PackageSource
forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
    BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting BuildOpts env BuildOpts -> RIO env BuildOpts)
-> Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall a b. (a -> b) -> a -> b
$ (Config -> Const BuildOpts Config) -> env -> Const BuildOpts env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const BuildOpts Config) -> env -> Const BuildOpts env)
-> ((BuildOpts -> Const BuildOpts BuildOpts)
    -> Config -> Const BuildOpts Config)
-> Getting BuildOpts env BuildOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> BuildOpts) -> SimpleGetter Config BuildOpts
forall s a. (s -> a) -> SimpleGetter s a
to Config -> BuildOpts
configBuild
    Map PackageName PackageSource
deps <- Map PackageName DepPackage
-> (DepPackage -> RIO env PackageSource)
-> RIO env (Map PackageName PackageSource)
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) ((DepPackage -> RIO env PackageSource)
 -> RIO env (Map PackageName PackageSource))
-> (DepPackage -> RIO env PackageSource)
-> RIO env (Map PackageName PackageSource)
forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
      case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
        PLImmutable PackageLocationImmutable
loc ->
          PackageSource -> RIO env PackageSource
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageSource -> RIO env PackageSource)
-> PackageSource -> RIO env PackageSource
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 <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
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 <- ProjectPackage -> RIO env LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
          PackageSource -> RIO env PackageSource
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageSource -> RIO env PackageSource)
-> PackageSource -> RIO env PackageSource
forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
    Map PackageName PackageSource
-> RIO env (Map PackageName PackageSource)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName PackageSource
 -> RIO env (Map PackageName PackageSource))
-> Map PackageName PackageSource
-> RIO env (Map PackageName PackageSource)
forall a b. (a -> b) -> a -> b
$ Map PackageName PackageSource
pPackages Map PackageName PackageSource
-> Map PackageName PackageSource -> Map PackageName PackageSource
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 = Map PackageName Task -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (Map PackageName Task -> [PackageName])
-> Map PackageName Task -> [PackageName]
forall a b. (a -> b) -> a -> b
$ (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Task
t -> Task -> InstallLocation
taskLocation Task
t InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) Map PackageName Task
tasks
  let snapExes :: [Text]
snapExes = Map Text InstallLocation -> [Text]
forall k a. Map k a -> [k]
Map.keys (Map Text InstallLocation -> [Text])
-> Map Text InstallLocation -> [Text]
forall a b. (a -> b) -> a -> b
$ (InstallLocation -> Bool)
-> Map Text InstallLocation -> Map Text InstallLocation
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) Map Text InstallLocation
installExes
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
snapTasks Bool -> Bool -> Bool
&& [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
snapExes) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NotOnlyLocal -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (NotOnlyLocal -> RIO env ()) -> NotOnlyLocal -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [PackageName] -> [Text] -> NotOnlyLocal
NotOnlyLocal [PackageName]
snapTasks [Text]
snapExes
  Plan -> RIO env Plan
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Plan
plan

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

instance Exception NotOnlyLocal where
  displayException :: NotOnlyLocal -> [Char]
displayException (NotOnlyLocal [PackageName]
packages [Text]
exes) = [[Char]] -> [Char]
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 [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
packages then [Char]
"" else [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Packages: "
        , [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
", " ((PackageName -> [Char]) -> [PackageName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString [PackageName]
packages)
        , [Char]
"\n"
        ]
    , if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
exes then [Char]
"" else [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Executables: "
        , [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
", " ((Text -> [Char]) -> [Text] -> [[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 Map GhcPkgId (PackageIdentifier, Text)
forall k a. Map k a
Map.empty [DumpPackage]
localDumpPkgs
 where
  loop ::
       Map GhcPkgId (PackageIdentifier, Text)
       -- ^ Current local packages to unregister.

    -> [DumpPackage]
       -- ^ Current local packages to keep.

    -> Map GhcPkgId (PackageIdentifier, Text)
       -- ^ Revised local packages to unregister.

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

  go :: DumpPackage -> State UnregisterState ()
  go :: DumpPackage -> State UnregisterState ()
go DumpPackage
dp = do
    UnregisterState
us <- StateT UnregisterState Identity UnregisterState
forall s (m :: * -> *). MonadState s m => m s
get
    case Map GhcPkgId (PackageIdentifier, Text)
-> PackageIdentifier
-> Maybe PackageIdentifier
-> [GhcPkgId]
-> Maybe Text
maybeUnregisterReason (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) PackageIdentifier
ident Maybe PackageIdentifier
mParentLibId [GhcPkgId]
deps of
      -- Not unregistering, add it to the keep list.

      Maybe Text
Nothing -> UnregisterState -> State UnregisterState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us { usKeep :: [DumpPackage]
usKeep = DumpPackage
dp DumpPackage -> [DumpPackage] -> [DumpPackage]
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 -> UnregisterState -> State UnregisterState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us
        { usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = GhcPkgId
-> (PackageIdentifier, Text)
-> Map GhcPkgId (PackageIdentifier, Text)
-> Map GhcPkgId (PackageIdentifier, Text)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert GhcPkgId
gid (PackageIdentifier
ident, Text
reason) (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us)
        , usAnyAdded :: Bool
usAnyAdded = Bool
True
        }
   where
    gid :: GhcPkgId
gid = DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp
    ident :: PackageIdentifier
ident = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
    mParentLibId :: Maybe PackageIdentifier
mParentLibId = DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp
    deps :: [GhcPkgId]
deps = DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp

  maybeUnregisterReason ::
       Map GhcPkgId (PackageIdentifier, Text)
       -- ^ Current local packages to unregister.

    -> PackageIdentifier
       -- ^ Package identifier.

    -> Maybe PackageIdentifier
       -- ^ If package for sub library, package identifier of the parent.

    -> [GhcPkgId]
       -- ^ Dependencies of the package.

    -> Maybe Text
       -- ^ If to be unregistered, the reason for doing so.

  maybeUnregisterReason :: Map GhcPkgId (PackageIdentifier, Text)
-> PackageIdentifier
-> Maybe PackageIdentifier
-> [GhcPkgId]
-> Maybe Text
maybeUnregisterReason Map GhcPkgId (PackageIdentifier, Text)
toUnregister PackageIdentifier
ident Maybe PackageIdentifier
mParentLibId [GhcPkgId]
deps
    -- If the package is not for a sub library, then it is directly relevant. If

    -- it is, then the relevant package is the parent. If we are planning on

    -- running a task on the relevant package, then the package must be

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

    -- being done.

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

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

    | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
    where
      -- If the package is not for a sub library, then the relevant package

      -- identifier is that of the package. If it is, then the relevant package

      -- identifier is that of the parent.

      relevantPkgId :: PackageIdentifier
      relevantPkgId :: PackageIdentifier
relevantPkgId = PackageIdentifier -> Maybe PackageIdentifier -> PackageIdentifier
forall a. a -> Maybe a -> a
fromMaybe PackageIdentifier
ident Maybe PackageIdentifier
mParentLibId
      -- If the package is not for a sub library, then the relevant package name

      -- is that of the package. If it is, then the relevant package name is

      -- that of the parent.

      relevantPkgName :: PackageName
      relevantPkgName :: PackageName
relevantPkgName = PackageName
-> (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier
-> PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) PackageIdentifier -> PackageName
pkgName Maybe PackageIdentifier
mParentLibId

-- | 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 -> Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException Task
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException Task))
-> Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException Task
forall a b. a -> Either a b
Left ConstructPlanException
e
    Right (Set PackageIdentifier
missing, Map PackageIdentifier GhcPkgId
present, IsMutable
_minLoc) -> do
      Ctx
ctx <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
      Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException Task
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException Task))
-> Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall a b. (a -> b) -> a -> b
$ Task -> Either ConstructPlanException Task
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 ((Map PackageIdentifier GhcPkgId -> ConfigureOpts)
 -> TaskConfigOpts)
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
            let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = Map PackageIdentifier GhcPkgId
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
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
                  (Getting EnvConfig Ctx EnvConfig -> Ctx -> EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig Ctx EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx 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 (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)))
        , taskAnyMissing :: Bool
taskAnyMissing = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
        , taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
        }
  W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wFinals :: Map PackageName (Either ConstructPlanException Task)
wFinals = PackageName
-> Either ConstructPlanException Task
-> Map PackageName (Either ConstructPlanException Task)
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. First checks if the package name is in the library map.

--

-- '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.

getCachedDepOrAddDep ::
     PackageName
  -> M (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep :: PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep PackageName
name = do
  Map PackageName (Either ConstructPlanException AddDepRes)
libMap <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Map PackageName (Either ConstructPlanException AddDepRes))
forall s (m :: * -> *). MonadState s m => m s
get
  case PackageName
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> Maybe (Either ConstructPlanException AddDepRes)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
libMap of
    Just Either ConstructPlanException AddDepRes
res -> do
      Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"getCachedDepOrAddDep" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Using cached result for "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Either ConstructPlanException AddDepRes -> [Char]
forall a. Show a => a -> [Char]
show Either ConstructPlanException AddDepRes
res)
      Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res
    Maybe (Either ConstructPlanException AddDepRes)
Nothing -> PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
checkCallStackAndAddDep PackageName
name

-- | Given a 'PackageName', known not to be in the library map, adds all of the

-- build tasks to build the package. First checks that the package name is not

-- already in the call stack.

checkCallStackAndAddDep ::
     PackageName
  -> M (Either ConstructPlanException AddDepRes)
checkCallStackAndAddDep :: PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
checkCallStackAndAddDep PackageName
name = do
  Ctx
ctx <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Either ConstructPlanException AddDepRes
res <- if PackageName
name PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Ctx -> [PackageName]
callStack Ctx
ctx
    then do
      Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"checkCallStackAndAddDep" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Detected cycle "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (PackageName -> [Char]) -> [PackageName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString (Ctx -> [PackageName]
callStack Ctx
ctx))
      Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException AddDepRes
forall a b. a -> Either a b
Left (ConstructPlanException -> Either ConstructPlanException AddDepRes)
-> ConstructPlanException
-> Either ConstructPlanException AddDepRes
forall a b. (a -> b) -> a -> b
$ [PackageName] -> ConstructPlanException
DependencyCycleDetected ([PackageName] -> ConstructPlanException)
-> [PackageName] -> ConstructPlanException
forall a b. (a -> b) -> a -> b
$ PackageName
name PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx
    else case PackageName -> CombinedMap -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (CombinedMap -> Maybe PackageInfo)
-> CombinedMap -> Maybe PackageInfo
forall a b. (a -> b) -> a -> b
$ Ctx -> CombinedMap
combinedMap Ctx
ctx of
      -- TODO look up in the package index and see if there's a

      -- recommendation available

      Maybe PackageInfo
Nothing -> do
        Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"checkCallStackAndAddDep" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
             Utf8Builder
"No package info for "
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"."
        Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException AddDepRes
forall a b. a -> Either a b
Left (ConstructPlanException -> Either ConstructPlanException AddDepRes)
-> ConstructPlanException
-> Either ConstructPlanException AddDepRes
forall a b. (a -> b) -> a -> b
$ PackageName -> ConstructPlanException
UnknownPackage PackageName
name
      Just PackageInfo
packageInfo ->
        -- Add the current package name to the head of the call stack.

        (Ctx -> Ctx)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
(Ctx -> Ctx)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Ctx
ctx' -> Ctx
ctx' { callStack :: [PackageName]
callStack = PackageName
name PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx' }) (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   (Either ConstructPlanException AddDepRes)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$
          PackageName
-> PackageInfo
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
addDep PackageName
name PackageInfo
packageInfo
  PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
  Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res

-- | Given a 'PackageName' and its 'PackageInfo' from the combined map, adds all

-- of the build tasks to build the package. Assumes that the head of the call

-- stack is the current package name.

addDep ::
     PackageName
  -> PackageInfo
  -> M (Either ConstructPlanException AddDepRes)
addDep :: PackageName
-> PackageInfo
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
addDep PackageName
name PackageInfo
packageInfo = do
  Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"addDep" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Package info for "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageInfo -> [Char]
forall a. Show a => a -> [Char]
show PackageInfo
packageInfo)
  case PackageInfo
packageInfo of
    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 = RIO Ctx (Maybe PackageLocationImmutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m) =>
RIO env a -> m a
liftRIO (RIO Ctx (Maybe PackageLocationImmutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe PackageLocationImmutable))
-> RIO Ctx (Maybe PackageLocationImmutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ do
            Maybe (Revision, BlobKey, TreeKey)
mrev <- RequireHackageIndex
-> PackageName
-> Version
-> RIO Ctx (Maybe (Revision, BlobKey, TreeKey))
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.

                [PackageName]
cs <- (Ctx -> [PackageName]) -> RIO Ctx [PackageName]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([PackageName] -> [PackageName]
forall a. (?callStack::CallStack) => [a] -> [a]
L.tail ([PackageName] -> [PackageName])
-> (Ctx -> [PackageName]) -> Ctx -> [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> [PackageName]
callStack)
                [StyleDoc] -> RIO Ctx ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                  ([StyleDoc] -> RIO Ctx ()) -> [StyleDoc] -> RIO Ctx ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"No latest package revision found for"
                  StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
                  StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [Char] -> StyleDoc
flow [Char]
"dependency callstack:"
                  StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList Maybe Style
forall a. Maybe a
Nothing Bool
False
                      ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc)
-> (PackageName -> [Char]) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) [PackageName]
cs :: [StyleDoc])
                Maybe PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall a. a -> RIO Ctx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
              Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) ->
                Maybe PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall a. a -> RIO Ctx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
 -> RIO Ctx (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (PackageLocationImmutable -> Maybe PackageLocationImmutable)
-> PackageLocationImmutable -> Maybe PackageLocationImmutable
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 Map FlagName Bool
forall k a. Map k a
Map.empty
      Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. b -> Either a b
Right (AddDepRes -> Either ConstructPlanException AddDepRes)
-> AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. (a -> b) -> a -> b
$ InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
    PIOnlySource PackageSource
ps -> do
      PackageName
-> PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutables PackageName
name PackageSource
ps
      PackageName
-> PackageSource
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
forall a. Maybe a
Nothing
    PIBoth PackageSource
ps Installed
installed -> do
      PackageName
-> PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutables PackageName
name PackageSource
ps
      PackageName
-> PackageSource
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps (Installed -> Maybe Installed
forall a. a -> Maybe a
Just Installed
installed)

-- 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 (Package
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Package
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
  | Bool
otherwise = ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
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 (Maybe PackageLocationImmutable
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Maybe PackageLocationImmutable
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Ctx -> Set PackageName
wanted Ctx
ctx) (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   ()
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe PackageLocationImmutable
mPkgLoc <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Maybe PackageLocationImmutable)
retrievePkgLoc
    Maybe PackageLocationImmutable
-> (PackageLocationImmutable
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PackageLocationImmutable
mPkgLoc ((PackageLocationImmutable
  -> RWST
       Ctx
       W
       (Map PackageName (Either ConstructPlanException AddDepRes))
       IO
       ())
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> (PackageLocationImmutable
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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 <- (Ctx -> CombinedMap)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     CombinedMap
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 PackageName -> CombinedMap -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Package -> PackageName
packageName Package
p) CombinedMap
cm of
          Maybe PackageInfo
Nothing -> Bool -> Set Text -> Set Text
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Set Text
forall a. Set a
Set.empty
          Just (PIOnlyInstalled InstallLocation
_ Installed
_) -> Set Text
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 = Set Text
forall a. Set a
Set.empty
      goSource PSRemote{} = Set Text
forall a. Set a
Set.empty

  W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty
    { wInstall :: Map Text InstallLocation
wInstall = [(Text, InstallLocation)] -> Map Text InstallLocation
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, InstallLocation)] -> Map Text InstallLocation)
-> [(Text, InstallLocation)] -> Map Text InstallLocation
forall a b. (a -> b) -> a -> b
$
        (Text -> (Text, InstallLocation))
-> [Text] -> [(Text, InstallLocation)]
forall a b. (a -> b) -> [a] -> [b]
map (, InstallLocation
loc) ([Text] -> [(Text, InstallLocation)])
-> [Text] -> [(Text, InstallLocation)]
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Text -> Set Text -> Set Text
forall {a}. Ord a => Set a -> Set a -> Set a
filterComps Set Text
myComps (Set Text -> Set Text) -> Set Text -> Set Text
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
    | Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
myComps = Set a
x
    | Bool
otherwise = Set a -> Set a -> Set a
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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
minstalled = do
  Ctx
ctx <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  case PackageSource
ps of
    PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
cp -> do
      Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Doing all-in-one build for upstream package "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"."
      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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (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
          Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"No test or bench component for "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" so doing an all-in-one build."
          Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (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)
libMap <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Map PackageName (Either ConstructPlanException AddDepRes))
forall s (m :: * -> *). MonadState s m => m s
get
          Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
   W -> W)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (a, W -> W)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   (Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
    W -> W)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
      W -> W)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
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
_ -> a
forall a. Monoid a => a
mempty
                  Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
_ -> a
w
            (Either
   ConstructPlanException
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
 W -> W)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
      W -> W)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res, W -> W
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
              Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
                   Utf8Builder
"For "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", 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 (Maybe Curator -> Bool)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Curator)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ctx -> Maybe Curator)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Curator)
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
              Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ AddDepRes -> Either ConstructPlanException AddDepRes
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.

              Text
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Utf8Builder
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
                   Utf8Builder
"Before trying cyclic plan, resetting lib result map to: "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Map PackageName (Either ConstructPlanException AddDepRes) -> [Char]
forall a. Show a => a -> [Char]
show Map PackageName (Either ConstructPlanException AddDepRes)
libMap)
              Map PackageName (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Map PackageName (Either ConstructPlanException AddDepRes)
libMap
              -- Otherwise, fall back on building the tests / benchmarks in a

              -- separate step.

              Either ConstructPlanException AddDepRes
res' <- Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall
                Bool
False (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps (LocalPackage -> Package
lpPackage LocalPackage
lp) Maybe Installed
minstalled
              Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either ConstructPlanException AddDepRes -> Bool
forall a b. Either a b -> Bool
isRight Either ConstructPlanException AddDepRes
res') (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   ()
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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
              Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res'
 where
  expectedTestOrBenchFailures :: Maybe Curator -> Bool
expectedTestOrBenchFailures Maybe Curator
maybeCurator = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    Curator
curator <- Maybe Curator
maybeCurator
    Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name (Curator -> Set PackageName
curatorExpectTestFailure Curator
curator) Bool -> Bool -> Bool
||
           PackageName -> Set PackageName -> 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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (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 -> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException AddDepRes
forall a b. a -> Either a b
Left ConstructPlanException
err
    Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps ->
      AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. b -> Either a b
Right (AddDepRes -> Either ConstructPlanException AddDepRes)
-> M AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> M AddDepRes
installPackageGivenDeps
          Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps

-- | 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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe Installed
mRightVersionInstalled <- case (Maybe Installed
minstalled, Set PackageIdentifier -> Bool
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
        Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Installed
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Installed))
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall a b. (a -> b) -> a -> b
$ if Bool
shouldInstall then Maybe Installed
forall a. Maybe a
Nothing else Installed -> Maybe Installed
forall a. a -> Maybe a
Just Installed
installed
      (Just Installed
_, Bool
False) -> do
        let t :: Text
t = Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                  (PackageIdentifier -> Text) -> [PackageIdentifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text)
-> (PackageIdentifier -> [Char]) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString (PackageName -> [Char])
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName) (Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing)
        W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty
          { wDirty :: Map PackageName Text
wDirty =
              PackageName -> Text -> Map PackageName Text
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (Text -> Map PackageName Text) -> Text -> Map PackageName Text
forall a b. (a -> b) -> a -> b
$ Text
"missing dependencies: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis Text
t
          }
        Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
      (Maybe Installed
Nothing, Bool
_) -> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
    let loc :: InstallLocation
loc = PackageSource -> InstallLocation
psLocation PackageSource
ps
        mutable :: IsMutable
mutable = InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc IsMutable -> IsMutable -> IsMutable
forall a. Semigroup a => a -> a -> a
<> IsMutable
minMutable
    AddDepRes -> M AddDepRes
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddDepRes -> M AddDepRes) -> AddDepRes -> M AddDepRes
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 ((Map PackageIdentifier GhcPkgId -> ConfigureOpts)
 -> TaskConfigOpts)
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
            let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = Map PackageIdentifier GhcPkgId
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
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
                  (Getting EnvConfig Ctx EnvConfig -> Ctx -> EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig Ctx EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx 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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> Bool
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 BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
Configure

-- Update response in the library 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 = (Map PackageName (Either ConstructPlanException AddDepRes)
 -> Map PackageName (Either ConstructPlanException AddDepRes))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map PackageName (Either ConstructPlanException AddDepRes)
  -> Map PackageName (Either ConstructPlanException AddDepRes))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> (Map PackageName (Either ConstructPlanException AddDepRes)
    -> Map PackageName (Either ConstructPlanException AddDepRes))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ \Map PackageName (Either ConstructPlanException AddDepRes)
mp ->
  case (PackageName
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> Maybe (Either ConstructPlanException AddDepRes)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
mp, Either ConstructPlanException AddDepRes
val) of
    (Just (Left DependencyCycleDetected{}), Left ConstructPlanException
_) -> Map PackageName (Either ConstructPlanException AddDepRes)
mp
    (Maybe (Either ConstructPlanException AddDepRes),
 Either ConstructPlanException AddDepRes)
_ -> PackageName
-> Either ConstructPlanException AddDepRes
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> Map PackageName (Either ConstructPlanException AddDepRes)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
name Either ConstructPlanException AddDepRes
val Map PackageName (Either ConstructPlanException AddDepRes)
mp

addEllipsis :: Text -> Text
addEllipsis :: Text -> Text
addEllipsis Text
t
  | Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100 = Text
t
  | Bool
otherwise = Int -> Text -> Text
T.take Int
97 Text
t Text -> Text -> Text
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  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 <- [(PackageName, DepValue)]
-> ((PackageName, DepValue)
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Either
            (PackageName,
             (VersionRange, Maybe (Version, BlobKey), BadDependency))
            (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
             IsMutable)))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PackageName DepValue -> [(PackageName, DepValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName DepValue
deps') (((PackageName, DepValue)
  -> RWST
       Ctx
       W
       (Map PackageName (Either ConstructPlanException AddDepRes))
       IO
       (Either
          (PackageName,
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
          (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
           IsMutable)))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      [Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)])
-> ((PackageName, DepValue)
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Either
            (PackageName,
             (VersionRange, Maybe (Version, BlobKey), BadDependency))
            (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
             IsMutable)))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
forall a b. (a -> b) -> a -> b
$ \(PackageName
depname, DepValue VersionRange
range DepType
depType) -> do
    Either ConstructPlanException AddDepRes
eres <- PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep PackageName
depname
    let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
        getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev = do
          Map Version (Map Revision BlobKey)
vsAndRevs <-
            Ctx
-> RIO Ctx (Map Version (Map Revision BlobKey))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Map Version (Map Revision BlobKey))
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx (RIO Ctx (Map Version (Map Revision BlobKey))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Map Version (Map Revision BlobKey)))
-> RIO Ctx (Map Version (Map Revision BlobKey))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Map Version (Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$
              RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO Ctx (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions
                RequireHackageIndex
YesRequireHackageIndex UsePreferredVersions
UsePreferredVersions PackageName
depname
          Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey)))
-> Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey))
forall a b. (a -> b) -> a -> b
$ do
            Version
lappVer <- VersionRange -> Set Version -> Maybe Version
latestApplicableVersion VersionRange
range (Set Version -> Maybe Version) -> Set Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Map Version (Map Revision BlobKey) -> Set Version
forall k a. Map k a -> Set k
Map.keysSet Map Version (Map Revision BlobKey)
vsAndRevs
            Map Revision BlobKey
revs <- Version
-> Map Version (Map Revision BlobKey)
-> Maybe (Map Revision BlobKey)
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
_) <- Map Revision BlobKey -> Maybe (BlobKey, Map Revision BlobKey)
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map Revision BlobKey
revs
            (Version, BlobKey) -> Maybe (Version, BlobKey)
forall a. a -> Maybe a
Just (Version
lappVer, BlobKey
cabalHash)
    case Either ConstructPlanException AddDepRes
eres of
      Left ConstructPlanException
e -> do
        PackageName
-> VersionRange
-> Maybe Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall {m :: * -> *}.
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range Maybe Version
forall a. Maybe a
Nothing
        let bd :: BadDependency
bd = case ConstructPlanException
e of
              UnknownPackage PackageName
name -> Bool -> BadDependency -> BadDependency
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageName
name PackageName -> PackageName -> Bool
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
        Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
mlatestApplicable, BadDependency
bd))
      Right AddDepRes
adr | DepType
depType DepType -> DepType -> Bool
forall a. Eq a => a -> a -> Bool
== DepType
AsLibrary Bool -> Bool -> Bool
&& Bool -> Bool
not (AddDepRes -> Bool
adrHasLibrary AddDepRes
adr) ->
        Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
forall a. Maybe a
Nothing, BadDependency
HasNoLibrary))
      Right AddDepRes
adr -> do
        PackageName
-> VersionRange
-> Maybe Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall {m :: * -> *}.
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range Maybe Version
forall a. Maybe a
Nothing
        Bool
inRange <- if AddDepRes -> Version
adrVersion AddDepRes
adr Version -> VersionRange -> Bool
`withinRange` VersionRange
range
          then Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else do
            let warn_ :: Bool -> StyleDoc -> m ()
warn_ Bool
isIgnoring StyleDoc
reason = W -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wWarnings :: [StyleDoc] -> [StyleDoc]
wWarnings = (StyleDoc
msg:) }
                 where
                  msg :: StyleDoc
msg =
                       [StyleDoc] -> StyleDoc
fillSep
                         [ if Bool
isIgnoring then StyleDoc
"Ignoring" else [Char] -> StyleDoc
flow [Char]
"Not ignoring"
                         , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc)
-> (PackageName -> [Char]) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"'s"
                         , [Char] -> StyleDoc
flow [Char]
"bounds on"
                         , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
depname)
                         , StyleDoc -> StyleDoc
parens ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> (Text -> [Char]) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
forall a b. (a -> b) -> a -> b
$ VersionRange -> Text
versionRangeText VersionRange
range)
                         , [Char] -> StyleDoc
flow [Char]
"and using"
                         , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc)
-> (PackageIdentifier -> [Char]) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                             PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                         ]
                    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                         [ StyleDoc
"Reason:"
                         , StyleDoc
reason StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                         ]
            Bool
allowNewer <- Getting Bool Ctx Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool Ctx Bool
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      Bool)
-> Getting Bool Ctx Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> Ctx -> Const Bool Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> Const Bool Config) -> Ctx -> Const Bool Ctx)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool Ctx Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
            Maybe [PackageName]
allowNewerDeps <- Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe [PackageName])
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe [PackageName]))
-> Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe [PackageName])
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe [PackageName]) Config)
-> Ctx -> Const (Maybe [PackageName]) Ctx
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL((Config -> Const (Maybe [PackageName]) Config)
 -> Ctx -> Const (Maybe [PackageName]) Ctx)
-> ((Maybe [PackageName]
     -> Const (Maybe [PackageName]) (Maybe [PackageName]))
    -> Config -> Const (Maybe [PackageName]) Config)
-> Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Maybe [PackageName])
-> SimpleGetter Config (Maybe [PackageName])
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
                      Bool
-> StyleDoc
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True
                        ( [Char] -> StyleDoc
flow [Char]
"trusting snapshot over Cabal file dependency \
                               \information"
                        )
                      Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                    else Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            if Bool
allowNewer
              then case Maybe [PackageName]
allowNewerDeps of
                Maybe [PackageName]
Nothing -> do
                  Bool
-> StyleDoc
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True (StyleDoc
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> StyleDoc
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
                    [StyleDoc] -> StyleDoc
fillSep
                      [ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
                      , StyleDoc
"enabled"
                      ]
                  Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                Just [PackageName]
boundsIgnoredDeps -> do
                  let pkgName :: PackageName
pkgName = Package -> PackageName
packageName Package
package
                      pkgName' :: StyleDoc
pkgName' = [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pkgName
                      isBoundsIgnoreDep :: Bool
isBoundsIgnoreDep = PackageName
pkgName PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
boundsIgnoredDeps
                      reason :: StyleDoc
reason = if Bool
isBoundsIgnoreDep
                        then [StyleDoc] -> StyleDoc
fillSep
                          [ Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgName'
                          , [Char] -> StyleDoc
flow [Char]
"is an"
                          , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-dep"
                          , [Char] -> StyleDoc
flow [Char]
"and"
                          , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
                          , StyleDoc
"enabled"
                          ]
                        else [StyleDoc] -> StyleDoc
fillSep
                          [ Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgName'
                          , [Char] -> StyleDoc
flow [Char]
"is not an"
                          , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-dep"
                          , [Char] -> StyleDoc
flow [Char]
"although"
                          , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
                          , StyleDoc
"enabled"
                          ]
                  Bool
-> StyleDoc
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
isBoundsIgnoreDep StyleDoc
reason
                  Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBoundsIgnoreDep
              else do
                Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe [PackageName] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [PackageName]
allowNewerDeps) (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   ()
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
                  Bool
-> StyleDoc
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
False (StyleDoc
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> StyleDoc
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$
                    [StyleDoc] -> StyleDoc
fillSep
                      [ StyleDoc
"although"
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-deps"
                      , [Char] -> StyleDoc
flow [Char]
"are specified,"
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
                      , StyleDoc
"is"
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"false"
                      ]
                RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Bool
inSnapshotCheck
        if Bool
inRange
          then case AddDepRes
adr of
            ADRToInstall Task
task -> Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right
              ( PackageIdentifier -> Set PackageIdentifier
forall a. a -> Set a
Set.singleton (PackageIdentifier -> Set PackageIdentifier)
-> PackageIdentifier -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
              , Map PackageIdentifier GhcPkgId
forall k a. Map k a
Map.empty, Task -> IsMutable
taskTargetIsMutable Task
task
              )
            ADRFound InstallLocation
loc (Executable PackageIdentifier
_) -> Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right
              ( Set PackageIdentifier
forall a. Set a
Set.empty, Map PackageIdentifier GhcPkgId
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)
_) -> Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right
              ( Set PackageIdentifier
forall a. Set a
Set.empty, PackageIdentifier -> GhcPkgId -> Map PackageIdentifier GhcPkgId
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
            Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left
              ( PackageName
depname
              , ( VersionRange
range
                , Maybe (Version, BlobKey)
mlatestApplicable
                , Version -> BadDependency
DependencyMismatch (Version -> BadDependency) -> Version -> BadDependency
forall a b. (a -> b) -> a -> b
$ AddDepRes -> Version
adrVersion AddDepRes
adr
                )
              )
  case [Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
-> ([(PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))],
    [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
      IsMutable)])
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) -> Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   ConstructPlanException
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right ((Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. (a -> b) -> a -> b
$ [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
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)]
_) -> Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   ConstructPlanException
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ ConstructPlanException
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (ConstructPlanException
 -> Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
-> ConstructPlanException
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. (a -> b) -> a -> b
$ Package
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> ConstructPlanException
DependencyPlanFailures
      Package
package
      ([(PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
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 (PackageIdentifier -> Version) -> PackageIdentifier -> Version
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 =
    W -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wParents :: ParentMap
wParents = Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> ParentMap
forall k a. Map k a -> MonoidMap k a
MonoidMap (Map
   PackageName (First Version, [(PackageIdentifier, VersionRange)])
 -> ParentMap)
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> ParentMap
forall a b. (a -> b) -> a -> b
$ PackageName
-> (First Version, [(PackageIdentifier, VersionRange)])
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
forall k a. k -> a -> Map k a
Map.singleton PackageName
depname (First Version, [(PackageIdentifier, VersionRange)])
val }
   where
    val :: (First Version, [(PackageIdentifier, VersionRange)])
val = (Maybe Version -> First Version
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 (Package -> Bool) -> Package -> Bool
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 (Set Text -> Bool
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe ConfigCache
moldOpts <- Ctx
-> RIO Ctx (Maybe ConfigCache)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ConfigCache)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx (RIO Ctx (Maybe ConfigCache)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe ConfigCache))
-> RIO Ctx (Maybe ConfigCache)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ Installed -> RIO Ctx (Maybe ConfigCache)
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
        (Getting EnvConfig Ctx EnvConfig -> Ctx -> EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig Ctx EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' Ctx EnvConfig
envConfigL Ctx
ctx)
        (Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
        Map PackageIdentifier GhcPkgId
present
        (PackageSource -> Bool
psLocal PackageSource
ps)
        (InstallLocation -> IsMutable
installLocationIsMutable (InstallLocation -> IsMutable) -> InstallLocation -> IsMutable
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 = [GhcPkgId] -> Set GhcPkgId
forall a. Ord a => [a] -> Set a
Set.fromList ([GhcPkgId] -> Set GhcPkgId) -> [GhcPkgId] -> Set GhcPkgId
forall a b. (a -> b) -> a -> b
$ Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
present
        , configCacheComponents :: Set ByteString
configCacheComponents =
            case PackageSource
ps of
              PSFilePath LocalPackage
lp ->
                (NamedComponent -> ByteString)
-> Set NamedComponent -> Set ByteString
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (NamedComponent -> Text) -> NamedComponent -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) (Set NamedComponent -> Set ByteString)
-> Set NamedComponent -> Set ByteString
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
              PSRemote{} -> Set ByteString
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 = Getting Config Ctx Config -> Ctx -> Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config Ctx Config
forall env. HasConfig env => Lens' env Config
Lens' Ctx Config
configL Ctx
ctx
  Maybe Text
mreason <-
    case Maybe ConfigCache
moldOpts of
      Maybe ConfigCache
Nothing -> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
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 ->
            Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason
        | Bool
True <- PackageSource -> Bool
psForceDirty PackageSource
ps -> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"--force-dirty specified"
        | Bool
otherwise -> do
            Maybe (Set [Char])
dirty <- PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe (Set [Char]))
forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set [Char]))
psDirty PackageSource
ps
            Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$
              case Maybe (Set [Char])
dirty of
                Just Set [Char]
files -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
                     Text
"local file changes: "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList Set [Char]
files)
                Maybe (Set [Char])
Nothing -> Maybe Text
forall a. Maybe a
Nothing
  case Maybe Text
mreason of
    Maybe Text
Nothing -> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Text
reason -> do
      W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wDirty :: Map PackageName Text
wDirty = PackageName -> Text -> Map PackageName Text
forall k a. k -> a -> Map k a
Map.singleton (Package -> PackageName
packageName Package
package) Text
reason }
      Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
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 CachePkgSrc -> CachePkgSrc -> Bool
forall a. Eq a => a -> a -> Bool
/= ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
      Text
"switching from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      CachePkgSrc -> Text
pkgSrcName (ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
old) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      CachePkgSrc -> Text
pkgSrcName (ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new)
  | Bool -> Bool
not (ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
new Set GhcPkgId -> Set GhcPkgId -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
old) =
      Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dependencies changed"
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set ByteString -> Bool
forall a. Set a -> Bool
Set.null Set ByteString
newComponents =
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"components added: " Text -> Text -> Text
`T.append` Text -> [Text] -> Text
T.intercalate Text
", "
          ((ByteString -> Text) -> [ByteString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) (Set ByteString -> [ByteString]
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 =
      Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rebuilding with haddocks"
  | [Text]
oldOpts [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text]
newOpts = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Char]
"flags changed from "
      , [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
oldOpts
      , [Char]
" to "
      , [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
newOpts
      ]
  | Bool
otherwise = Maybe Text
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 Text -> [Text] -> [Text]
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 ([Text] -> [Text]) -> [Text] -> [Text]
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 (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isKeeper ([Text] -> [Text]) -> [Text] -> [Text]
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) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> Text
T.unwords [Text]
keepers Text -> [Text] -> [Text]
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 = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-fhpc") -- more to be added later


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

    isStackOpt :: Text -> Bool
    isStackOpt :: Text -> Bool
isStackOpt Text
t = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
t)
      [ Text
"--dependency="
      , Text
"--constraint="
      , Text
"--package-db="
      , Text
"--libdir="
      , Text
"--bindir="
      , Text
"--datadir="
      , Text
"--libexecdir="
      , Text
"--sysconfdir"
      , Text
"--docdir="
      , Text
"--htmldir="
      , Text
"--haddockdir="
      , Text
"--enable-tests"
      , Text
"--enable-benchmarks"
      , Text
"--exact-configuration"
      -- Treat these as causing dirtiness, to resolve

      -- https://github.com/commercialhaskell/stack/issues/2984

      --

      -- , "--enable-library-profiling"

      -- , "--enable-executable-profiling"

      -- , "--enable-profiling"

      ] Bool -> Bool -> Bool
|| Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"--user"

  ([Text]
oldOpts, [Text]
newOpts) = [Text] -> [Text] -> ([Text], [Text])
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 a -> a -> Bool
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 Set ByteString -> Set ByteString -> Set ByteString
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) = MemoizedWith EnvConfig (Maybe (Set [Char]))
-> m (Maybe (Set [Char]))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith (MemoizedWith EnvConfig (Maybe (Set [Char]))
 -> m (Maybe (Set [Char])))
-> MemoizedWith EnvConfig (Maybe (Set [Char]))
-> m (Maybe (Set [Char]))
forall a b. (a -> b) -> a -> b
$ LocalPackage -> MemoizedWith EnvConfig (Maybe (Set [Char]))
lpDirtyFiles LocalPackage
lp
psDirty PSRemote {} = Maybe (Set [Char]) -> m (Maybe (Set [Char]))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set [Char])
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
  let unknownTools :: [ExeName]
unknownTools = Set ExeName -> [ExeName]
forall a. Set a -> [a]
Set.toList (Set ExeName -> [ExeName]) -> Set ExeName -> [ExeName]
forall a b. (a -> b) -> a -> b
$ Package -> Set ExeName
packageUnknownTools Package
p
  -- Check whether the tool is on the PATH or a package executable before

  -- warning about it.

  [ToolWarning]
warnings <-
    ([Maybe ToolWarning] -> [ToolWarning])
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [ToolWarning]
forall a b.
(a -> b)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ToolWarning] -> [ToolWarning]
forall a. [Maybe a] -> [a]
catMaybes (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   [Maybe ToolWarning]
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      [ToolWarning])
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [ToolWarning]
forall a b. (a -> b) -> a -> b
$ [ExeName]
-> (ExeName
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Maybe ToolWarning))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ExeName]
unknownTools ((ExeName
  -> RWST
       Ctx
       W
       (Map PackageName (Either ConstructPlanException AddDepRes))
       IO
       (Maybe ToolWarning))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      [Maybe ToolWarning])
-> (ExeName
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Maybe ToolWarning))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
forall a b. (a -> b) -> a -> b
$ \name :: ExeName
name@(ExeName Text
toolName) ->
      MaybeT
  (RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO)
  ToolWarning
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ToolWarning)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO)
   ToolWarning
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe ToolWarning))
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ToolWarning
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ToolWarning)
forall a b. (a -> b) -> a -> b
$ Text
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ()
forall {s} {m :: * -> *}.
(MonadReader s m, MonadIO m, HasConfig s) =>
Text -> MaybeT m ()
notOnPath Text
toolName MaybeT
  (RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO)
  ()
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ()
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ()
forall a b.
MaybeT
  (RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO)
  a
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     b
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ()
forall {m :: * -> *}. Applicative m => Text -> MaybeT m ()
notPackageExe Text
toolName MaybeT
  (RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO)
  ()
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ToolWarning
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ToolWarning
forall a b.
MaybeT
  (RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO)
  a
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     b
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ExeName
-> MaybeT
     (RWST
        Ctx
        W
        (Map PackageName (Either ConstructPlanException AddDepRes))
        IO)
     ToolWarning
forall {m :: * -> *}.
Applicative m =>
ExeName -> MaybeT m ToolWarning
warn ExeName
name
  W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wWarnings :: [StyleDoc] -> [StyleDoc]
wWarnings = ((ToolWarning -> StyleDoc) -> [ToolWarning] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> StyleDoc
toolWarningText [ToolWarning]
warnings ++) }
  ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  -- From Cabal 2.0, build-tools can specify a pre-built executable that should

  -- already be on the PATH.

  notOnPath :: Text -> MaybeT m ()
notOnPath Text
toolName = m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ()) -> MaybeT m ()) -> m (Maybe ()) -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ do
    let settings :: EnvSettings
settings = EnvSettings
minimalEnvSettings { esIncludeLocals :: Bool
esIncludeLocals = Bool
True }
    Config
config <- Getting Config s Config -> m Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config s Config
forall env. HasConfig env => Lens' env Config
Lens' s Config
configL
    ProcessContext
menv <- IO ProcessContext -> m ProcessContext
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> m ProcessContext)
-> IO ProcessContext -> m ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
settings
    Either ProcessException [Char]
eFound <- ProcessContext
-> RIO ProcessContext (Either ProcessException [Char])
-> m (Either ProcessException [Char])
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ProcessContext
menv (RIO ProcessContext (Either ProcessException [Char])
 -> m (Either ProcessException [Char]))
-> RIO ProcessContext (Either ProcessException [Char])
-> m (Either ProcessException [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> RIO ProcessContext (Either ProcessException [Char])
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable ([Char] -> RIO ProcessContext (Either ProcessException [Char]))
-> [Char] -> RIO ProcessContext (Either ProcessException [Char])
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
toolName
    Bool -> m (Maybe ())
forall {f :: * -> *}. Applicative f => Bool -> f (Maybe ())
skipIf (Bool -> m (Maybe ())) -> Bool -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ Either ProcessException [Char] -> Bool
forall a b. Either a b -> Bool
isRight Either ProcessException [Char]
eFound
  -- From Cabal 1.12, build-tools can specify another executable in the same

  -- package.

  notPackageExe :: Text -> MaybeT m ()
notPackageExe Text
toolName = m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ()) -> MaybeT m ()) -> m (Maybe ()) -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Bool -> m (Maybe ())
forall {f :: * -> *}. Applicative f => Bool -> f (Maybe ())
skipIf (Bool -> m (Maybe ())) -> Bool -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ Text
toolName Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Package -> Set Text
packageExes Package
p
  warn :: ExeName -> MaybeT m ToolWarning
warn ExeName
name = m (Maybe ToolWarning) -> MaybeT m ToolWarning
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ToolWarning) -> MaybeT m ToolWarning)
-> (ToolWarning -> m (Maybe ToolWarning))
-> ToolWarning
-> MaybeT m ToolWarning
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ToolWarning -> m (Maybe ToolWarning)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ToolWarning -> m (Maybe ToolWarning))
-> (ToolWarning -> Maybe ToolWarning)
-> ToolWarning
-> m (Maybe ToolWarning)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToolWarning -> Maybe ToolWarning
forall a. a -> Maybe a
Just (ToolWarning -> MaybeT m ToolWarning)
-> ToolWarning -> MaybeT m ToolWarning
forall a b. (a -> b) -> a -> b
$ ExeName -> PackageName -> ToolWarning
ToolWarning ExeName
name (Package -> PackageName
packageName Package
p)
  skipIf :: Bool -> f (Maybe ())
skipIf Bool
p' = Maybe () -> f (Maybe ())
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe () -> f (Maybe ())) -> Maybe () -> f (Maybe ())
forall a b. (a -> b) -> a -> b
$ if Bool
p' then Maybe ()
forall a. Maybe a
Nothing else () -> Maybe ()
forall a. a -> Maybe a
Just ()

-- | 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]
(Int -> ToolWarning -> ShowS)
-> (ToolWarning -> [Char])
-> ([ToolWarning] -> ShowS)
-> Show ToolWarning
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ToolWarning -> ShowS
showsPrec :: Int -> ToolWarning -> ShowS
$cshow :: ToolWarning -> [Char]
show :: ToolWarning -> [Char]
$cshowList :: [ToolWarning] -> ShowS
showList :: [ToolWarning] -> ShowS
Show

toolWarningText :: ToolWarning -> StyleDoc
toolWarningText :: ToolWarning -> StyleDoc
toolWarningText (ToolWarning (ExeName Text
toolName) PackageName
pkgName') = [StyleDoc] -> StyleDoc
fillSep
  [ [Char] -> StyleDoc
flow [Char]
"No packages found in snapshot which provide a"
  , Style -> StyleDoc -> StyleDoc
style Style
PkgComponent ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
toolName)
  , [Char] -> StyleDoc
flow [Char]
"executable, which is a build-tool dependency of"
  , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ 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 = (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask (Map PackageName Task -> Map PackageName Task)
-> Map PackageName Task -> Map PackageName Task
forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
  , planFinals :: Map PackageName Task
planFinals = Map PackageName Task
forall k a. Map k a
Map.empty
  , planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal = Map GhcPkgId (PackageIdentifier, Text)
forall k a. Map k a
Map.empty
  , planInstallExes :: Map Text InstallLocation
planInstallExes = (InstallLocation -> Bool)
-> Map Text InstallLocation -> Map Text InstallLocation
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
/= InstallLocation
Local) (Map Text InstallLocation -> Map Text InstallLocation)
-> Map Text InstallLocation -> Map Text InstallLocation
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 InstallLocation -> InstallLocation -> Bool
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 = (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask (Map PackageName Task -> Map PackageName Task)
-> Map PackageName Task -> Map PackageName Task
forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
  , planFinals :: Map PackageName Task
planFinals = Map PackageName Task
forall k a. Map k a
Map.empty
  , planInstallExes :: Map Text InstallLocation
planInstallExes = Map Text InstallLocation
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 PackageIdentifier -> Set PackageIdentifier -> Bool
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) PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
deps
  missing :: Map PackageIdentifier (Set PackageIdentifier)
missing = [(PackageIdentifier, Set PackageIdentifier)]
-> Map PackageIdentifier (Set PackageIdentifier)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageIdentifier, Set PackageIdentifier)]
 -> Map PackageIdentifier (Set PackageIdentifier))
-> [(PackageIdentifier, Set PackageIdentifier)]
-> Map PackageIdentifier (Set PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ (Task -> (PackageIdentifier, Set PackageIdentifier))
-> [Task] -> [(PackageIdentifier, Set PackageIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map (Task -> PackageIdentifier
taskProvides (Task -> PackageIdentifier)
-> (Task -> Set PackageIdentifier)
-> Task
-> (PackageIdentifier, Set PackageIdentifier)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TaskConfigOpts -> Set PackageIdentifier
tcoMissing (TaskConfigOpts -> Set PackageIdentifier)
-> (Task -> TaskConfigOpts) -> Task -> Set PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> TaskConfigOpts
taskConfigOpts) ([Task] -> [(PackageIdentifier, Set PackageIdentifier)])
-> [Task] -> [(PackageIdentifier, Set PackageIdentifier)]
forall a b. (a -> b) -> a -> b
$
            Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Plan -> Map PackageName Task
planTasks Plan
plan)
  missingForDeps :: Set PackageIdentifier
missingForDeps = (State (Set PackageIdentifier) ()
 -> Set PackageIdentifier -> Set PackageIdentifier)
-> Set PackageIdentifier
-> State (Set PackageIdentifier) ()
-> Set PackageIdentifier
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Set PackageIdentifier) ()
-> Set PackageIdentifier -> Set PackageIdentifier
forall s a. State s a -> s -> s
execState Set PackageIdentifier
forall a. Monoid a => a
mempty (State (Set PackageIdentifier) () -> Set PackageIdentifier)
-> State (Set PackageIdentifier) () -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$
    [Task]
-> (Task -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task]) -> Map PackageName Task -> [Task]
forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan) ((Task -> State (Set PackageIdentifier) ())
 -> State (Set PackageIdentifier) ())
-> (Task -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
forall a b. (a -> b) -> a -> b
$ \Task
task ->
      Bool
-> State (Set PackageIdentifier) ()
-> State (Set PackageIdentifier) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Task -> Bool
providesDep Task
task) (State (Set PackageIdentifier) ()
 -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
-> State (Set PackageIdentifier) ()
forall a b. (a -> b) -> a -> b
$
        [PackageIdentifier]
-> PackageIdentifier -> State (Set PackageIdentifier) ()
forall {m :: * -> *}.
MonadState (Set PackageIdentifier) m =>
[PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
forall a. Monoid a => a
mempty (Task -> PackageIdentifier
taskProvides Task
task)

  collectMissing :: [PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
dependents PackageIdentifier
pid = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
pid PackageIdentifier -> [PackageIdentifier] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageIdentifier]
dependents) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      BuildException -> m ()
forall e a. Exception e => e -> a
impureThrow (BuildException -> m ()) -> BuildException -> m ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
TaskCycleBug PackageIdentifier
pid
    (Set PackageIdentifier -> Set PackageIdentifier) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (Set PackageIdentifier
-> Set PackageIdentifier -> Set PackageIdentifier
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> Set PackageIdentifier
forall a. a -> Set a
Set.singleton PackageIdentifier
pid)
    (PackageIdentifier -> m ()) -> Set PackageIdentifier -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing (PackageIdentifier
pidPackageIdentifier -> [PackageIdentifier] -> [PackageIdentifier]
forall a. a -> [a] -> [a]
:[PackageIdentifier]
dependents)) (Set PackageIdentifier
-> Maybe (Set PackageIdentifier) -> Set PackageIdentifier
forall a. a -> Maybe a -> a
fromMaybe Set PackageIdentifier
forall a. Monoid a => a
mempty (Maybe (Set PackageIdentifier) -> Set PackageIdentifier)
-> Maybe (Set PackageIdentifier) -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> Map PackageIdentifier (Set PackageIdentifier)
-> Maybe (Set PackageIdentifier)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a.
a
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      Bool)
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    PackageInfo
ps <- PackageName -> CombinedMap -> Maybe PackageInfo
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
_) ->
        Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Version
srcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version
      PIBoth (PSRemote PackageLocationImmutable
_ Version
srcVersion FromSnapshot
FromSnapshot CommonPackage
_) Installed
_ ->
        Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Version
srcVersion Version -> Version -> Bool
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) ->
        Bool -> Maybe Bool -> Maybe Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (InstallLocation
loc InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) (Maybe Bool -> Maybe Bool) -> Maybe Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
        Bool -> Maybe Bool -> Maybe Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pid Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version) (Maybe Bool -> Maybe Bool) -> Maybe Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
        Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      PackageInfo
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
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.


logDebugPlanS ::
     (HasCallStack, HasRunner env, MonadIO m, MonadReader env m)
  => LogSource
  -> Utf8Builder
  -> m ()
logDebugPlanS :: forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
s Utf8Builder
msg = do
  Bool
debugPlan <- Getting Bool env Bool -> m Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> m Bool)
-> Getting Bool env Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const Bool GlobalOpts) -> env -> Const Bool env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL((GlobalOpts -> Const Bool GlobalOpts) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool)
    -> GlobalOpts -> Const Bool GlobalOpts)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> Bool) -> SimpleGetter GlobalOpts Bool
forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Bool
globalPlanInLog
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugPlan (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Text -> Utf8Builder -> m ()
logDebugS Text
s Utf8Builder
msg