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

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

module Stack.Build.ConstructPlan
  ( constructPlan
  ) where

import           Control.Monad.Trans.Maybe ( MaybeT (..) )
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           Path ( parent )
import qualified RIO.NonEmpty as NE
import           RIO.Process ( findExecutable )
import           RIO.State
                   ( State, StateT (..), execState, get, modify, modify', put )
import           RIO.Writer ( WriterT (..), pass, tell )
import           Stack.Build.Cache ( tryGetFlagCache )
import           Stack.Build.Haddock ( shouldHaddockDeps )
import           Stack.Build.Source ( loadLocalPackage )
import           Stack.Constants ( compilerOptionsCabalFlag )
import           Stack.Package
                   ( applyForceCustomBuild, buildableExes, packageUnknownTools
                   , processPackageDepsToList
                   )
import           Stack.Prelude hiding ( loadPackage )
import           Stack.SourceMap ( getPLIVersion, mkProjectPackage )
import           Stack.Types.Build
                   ( CachePkgSrc (..), ConfigCache (..), Plan (..), Task (..)
                   , TaskConfigOpts (..), TaskType (..)
                   , installLocationIsMutable, taskIsTarget, taskLocation
                   , taskProvides, taskTargetIsMutable, toCachePkgSrc
                   )
import           Stack.Types.Build.ConstructPlan
                   ( AddDepRes (..), CombinedMap, Ctx (..), M, PackageInfo (..)
                   , ToolWarning(..), UnregisterState (..), W (..)
                   , adrHasLibrary, adrVersion, toTask
                   )
import           Stack.Types.Build.Exception
                   ( BadDependency (..), BuildException (..)
                   , BuildPrettyException (..), ConstructPlanException (..)
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), BuildSubset (..) )
import           Stack.Types.CompCollection ( collectionMember )
import           Stack.Types.Compiler ( WhichCompiler (..) )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..), stackRootL )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..) )
import qualified Stack.Types.ConfigureOpts as ConfigureOpts
import           Stack.Types.Curator ( Curator (..) )
import           Stack.Types.Dependency ( DepValue (..), isDepTypeLibrary )
import           Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent )
import           Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) )
import           Stack.Types.EnvSettings
                   ( EnvSettings (..), minimalEnvSettings )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Installed
                   ( InstallLocation (..), Installed (..), InstalledMap
                   , installedVersion
                   )
import           Stack.Types.IsMutable ( IsMutable (..) )
import           Stack.Types.NamedComponent ( exeComponents, renderComponent )
import           Stack.Types.Package
                   ( ExeName (..), LocalPackage (..), Package (..)
                   , PackageSource (..), installedMapGhcPkgId
                   , packageIdentifier, psVersion, runMemoizedWith
                   )
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
                   ( VersionRange, latestApplicableVersion, versionRangeText
                   , withinRange
                   )
import           System.Environment ( lookupEnv )

-- | 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]
        -- ^ GHC options

     -> [Text]
        -- ^ Cabal configure options

     -> RIO EnvConfig Package
     )
     -- ^ load upstream package

  -> SourceMap
  -> InstalledMap
  -> Bool
     -- ^ Only include initial build steps required for GHCi?

  -> 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
compilerPathsL Getting 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 (.cabalVersion)
    Map PackageName PackageSource
sources <- Version -> RIO env (Map PackageName PackageSource)
getSources Version
globalCabalVersion
    Maybe Curator
curator <- 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 (.curator)
    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
curator Text
pathEnvVar
        targetPackageNames :: [PackageName]
targetPackageNames = Map PackageName Target -> [PackageName]
forall k a. Map k a -> [k]
Map.keys SourceMap
sourceMap.targets.targets
        -- Ignore the result of 'getCachedDepOrAddDep'.

        onTarget :: PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
onTarget = WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Either ConstructPlanException AddDepRes)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   (Either ConstructPlanException AddDepRes)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> (PackageName
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Either ConstructPlanException AddDepRes))
-> PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep
        inner :: WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
inner = (PackageName
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> [PackageName]
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
onTarget [PackageName]
targetPackageNames
    (((), W Map PackageName (Either ConstructPlanException Task)
efinals Map Text InstallLocation
installExes Map PackageName Text
dirtyReason [StyleDoc] -> [StyleDoc]
warnings ParentMap
parents), Map PackageName (Either ConstructPlanException AddDepRes)
m) <-
      IO
  (((), W),
   Map PackageName (Either ConstructPlanException AddDepRes))
-> RIO
     env
     (((), W),
      Map PackageName (Either ConstructPlanException AddDepRes))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (((), W),
    Map PackageName (Either ConstructPlanException AddDepRes))
 -> RIO
      env
      (((), W),
       Map PackageName (Either ConstructPlanException AddDepRes)))
-> IO
     (((), W),
      Map PackageName (Either ConstructPlanException AddDepRes))
-> RIO
     env
     (((), W),
      Map PackageName (Either ConstructPlanException AddDepRes))
forall a b. (a -> b) -> a -> b
$ Ctx
-> RIO
     Ctx
     (((), W),
      Map PackageName (Either ConstructPlanException AddDepRes))
-> IO
     (((), W),
      Map PackageName (Either ConstructPlanException AddDepRes))
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx (StateT
  (Map PackageName (Either ConstructPlanException AddDepRes))
  (RIO Ctx)
  ((), W)
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> RIO
     Ctx
     (((), W),
      Map PackageName (Either ConstructPlanException AddDepRes))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
-> StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx)
     ((), W)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
inner) Map PackageName (Either ConstructPlanException AddDepRes)
forall k a. Map k a
Map.empty)
    -- Report any warnings

    (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 [])
    -- Separate out errors

    let ([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 k e v. (k, Either e v) -> Either e (k, v)
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 k e v. (k, Either e v) -> Either e (k, v)
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 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, Maybe Task) -> Maybe (PackageName, Task)
forall k v. (k, Maybe v) -> Maybe (k, v)
toMaybe ((PackageName, Maybe Task) -> Maybe (PackageName, Task))
-> ((PackageName, AddDepRes) -> (PackageName, Maybe Task))
-> (PackageName, AddDepRes)
-> Maybe (PackageName, Task)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AddDepRes -> Maybe Task)
-> (PackageName, AddDepRes) -> (PackageName, Maybe Task)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second AddDepRes -> Maybe Task
toTask) [(PackageName, AddDepRes)]
adrs
        Plan -> RIO env Plan
takeSubset Plan
          { $sel:tasks:Plan :: Map PackageName Task
tasks = Map PackageName Task
tasks
          , $sel:finals:Plan :: Map PackageName Task
finals = [(PackageName, Task)] -> Map PackageName Task
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, Task)]
finals
          , $sel:unregisterLocal:Plan :: Map GhcPkgId (PackageIdentifier, Text)
unregisterLocal =
              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
          , $sel:installExes:Plan :: Map Text InstallLocation
installExes =
              if    BaseConfigOpts
baseConfigOpts0.buildOpts.installExes
                 Bool -> Bool -> Bool
|| BaseConfigOpts
baseConfigOpts0.buildOpts.installCompilerTool
                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
. (.project))
        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
ctx.wanted
          Map PackageName [PackageName]
prunedGlobalDeps
 where
  sourceProject :: Map PackageName ProjectPackage
sourceProject = SourceMap
sourceMap.project
  sourceDeps :: Map PackageName DepPackage
sourceDeps = SourceMap
sourceMap.deps

  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") Map PackageName DepPackage
sourceDeps

  mkCtx :: EnvConfig
-> Version
-> Map PackageName PackageSource
-> Maybe Curator
-> Text
-> Ctx
mkCtx EnvConfig
ctxEnvConfig Version
globalCabalVersion Map PackageName PackageSource
sources Maybe Curator
curator Text
pathEnvVar = Ctx
    { baseConfigOpts :: BaseConfigOpts
baseConfigOpts = BaseConfigOpts
baseConfigOpts0
    , loadPackage :: PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Package
loadPackage = \PackageLocationImmutable
w Map FlagName Bool
x [Text]
y [Text]
z -> EnvConfig
-> RIO EnvConfig Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Package
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
ctxEnvConfig (RIO EnvConfig Package
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      Package)
-> RIO EnvConfig Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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 :: Map PackageName PackageInfo
combinedMap = Map PackageName PackageSource
-> InstalledMap -> Map PackageName PackageInfo
combineMap Map PackageName PackageSource
sources InstalledMap
installedMap
    , EnvConfig
ctxEnvConfig :: EnvConfig
ctxEnvConfig :: EnvConfig
ctxEnvConfig
    , callStack :: [PackageName]
callStack = []
    , wanted :: Set PackageName
wanted = Map PackageName Target -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet SourceMap
sourceMap.targets.targets
    , localNames :: Set PackageName
localNames = Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName ProjectPackage
sourceProject
    , Maybe Curator
curator :: Maybe Curator
curator :: Maybe Curator
curator
    , Text
pathEnvVar :: Text
pathEnvVar :: Text
pathEnvVar
    }

  toEither :: (k, Either e v) -> Either e (k, v)
  toEither :: forall k e v. (k, Either e v) -> Either e (k, v)
toEither (k
_, Left e
e)  = e -> Either e (k, v)
forall a b. a -> Either a b
Left e
e
  toEither (k
k, Right v
v) = (k, v) -> Either e (k, v)
forall a b. b -> Either a b
Right (k
k, v
v)

  toMaybe :: (k, Maybe v) -> Maybe (k, v)
  toMaybe :: forall k v. (k, Maybe v) -> Maybe (k, v)
toMaybe (k
_, Maybe v
Nothing) = Maybe (k, v)
forall a. Maybe a
Nothing
  toMaybe (k
k, Just v
v) = (k, v) -> Maybe (k, v)
forall a. a -> Maybe a
Just (k
k, v
v)

  takeSubset :: Plan -> RIO env Plan
  takeSubset :: Plan -> RIO env Plan
takeSubset = case BaseConfigOpts
baseConfigOpts0.buildOptsCLI.buildSubset 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
stripLocals
    BuildSubset
BSOnlyDependencies -> Plan -> RIO env Plan
stripNonDeps
    BuildSubset
BSOnlyLocals -> Plan -> RIO env Plan
errorOnSnapshot

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

  stripLocals :: Plan -> RIO env Plan
  stripLocals :: Plan -> RIO env Plan
stripLocals Plan
plan = Plan -> RIO env Plan
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Plan
plan
    { tasks = Map.filter checkTask plan.tasks
    , finals = Map.empty
    , unregisterLocal = Map.empty
    , installExes = Map.filter (/= Local) plan.installExes
    }
   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 :: Plan -> RIO env Plan
  stripNonDeps :: Plan -> RIO env Plan
stripNonDeps Plan
plan = Plan -> RIO env Plan
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Plan
plan
    { tasks = Map.filter checkTask plan.tasks
    , finals = Map.empty
    , installExes = Map.empty -- TODO maybe don't disable this?

    }
   where
    deps :: Set PackageName
deps = Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName DepPackage
sourceDeps
    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
    tasks :: [Task]
tasks = Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems Plan
plan.tasks
    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')
&&&  (.configOpts.missing)) [Task]
tasks
    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_ [Task]
tasks ((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)

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

  errorOnSnapshot :: Plan -> RIO env Plan
  errorOnSnapshot :: 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
        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
$
      BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [PackageName] -> [Text] -> BuildPrettyException
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

  prunedGlobalDeps :: Map PackageName [PackageName]
  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
sourceMap.globalPkgs ((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
   where
    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` Map PackageName DepPackage
sourceDeps Bool -> Bool -> Bool
|| PackageName
pname PackageName -> Map PackageName ProjectPackage -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map PackageName ProjectPackage
sourceProject

  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 LocalPackage
lp.package
          LocalPackage -> RIO env LocalPackage
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { 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 Map PackageName ProjectPackage
sourceProject ((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 (.build)
    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 Map PackageName DepPackage
sourceDeps ((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
dp.location 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
dp.fromSnapshot DepPackage
dp.depCommon
        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

-- | 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
us.anyAdded = Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop UnregisterState
us.toUnregister UnregisterState
us.toKeep
    -- Nothing added, so we've already caught them all. Return the Map we've

    -- already calculated.

    | Bool
otherwise = UnregisterState
us.toUnregister
   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
      { Map GhcPkgId (PackageIdentifier, Text)
toUnregister :: Map GhcPkgId (PackageIdentifier, Text)
toUnregister :: Map GhcPkgId (PackageIdentifier, Text)
toUnregister
      , toKeep :: [DumpPackage]
toKeep = []
      , anyAdded :: Bool
anyAdded = 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
us.toUnregister 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 { toKeep = dp : us.toKeep }
      -- 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
        { toUnregister = Map.insert gid (ident, reason) us.toUnregister
        , anyAdded = True
        }
   where
    gid :: GhcPkgId
gid = DumpPackage
dp.ghcPkgId
    ident :: PackageIdentifier
ident = DumpPackage
dp.packageIdent
    mParentLibId :: Maybe PackageIdentifier
mParentLibId = DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp
    deps :: [GhcPkgId]
deps = DumpPackage
dp.depends

  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
     -- ^ Will the build step also build the tests?

  -> Bool
     -- ^ Should Haddock documentation be built?

  -> M ()
addFinal :: LocalPackage
-> Package
-> Bool
-> Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException Task)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException Task
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException Task))
-> Either ConstructPlanException Task
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
      Either ConstructPlanException Task
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException Task)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException Task
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException Task))
-> Either ConstructPlanException Task
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException Task)
forall a b. (a -> b) -> a -> b
$ Task -> Either ConstructPlanException Task
forall a b. b -> Either a b
Right Task
        { $sel:configOpts:Task :: TaskConfigOpts
configOpts = 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.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
ctx.baseConfigOpts
                  Map PackageIdentifier GhcPkgId
allDeps
                  Bool
True -- local

                  IsMutable
Mutable
                  Package
package
        , Bool
buildHaddocks :: Bool
$sel:buildHaddocks:Task :: Bool
buildHaddocks
        , Map PackageIdentifier GhcPkgId
present :: Map PackageIdentifier GhcPkgId
$sel:present:Task :: Map PackageIdentifier GhcPkgId
present
        , $sel:taskType:Task :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
        , $sel:allInOne:Task :: Bool
allInOne = Bool
isAllInOne
        , $sel:cachePkgSrc:Task :: CachePkgSrc
cachePkgSrc = [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
lp.cabalFP))
        , $sel:buildTypeConfig:Task :: Bool
buildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
        }
  W
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wFinals = Map.singleton package.name 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep PackageName
name = do
  Map PackageName (Either ConstructPlanException AddDepRes)
libMap <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"getCachedDepOrAddDep" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Using cached result for "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res
    Maybe (Either ConstructPlanException AddDepRes)
Nothing -> PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
checkCallStackAndAddDep PackageName
name = do
  Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  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
ctx.callStack
    then do
      Text
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"checkCallStackAndAddDep" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Detected cycle "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName 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
ctx.callStack)
      Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
ctx.callStack
    else case PackageName -> Map PackageName PackageInfo -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Ctx
ctx.combinedMap of
      -- TODO look up in the package index and see if there's a

      -- recommendation available

      Maybe PackageInfo
Nothing -> do
        Text
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"checkCallStackAndAddDep" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
             Utf8Builder
"No package info for "
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"."
        Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
(Ctx -> Ctx)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Ctx
ctx' -> Ctx
ctx' { callStack = name : ctx'.callStack }) (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   (Either ConstructPlanException AddDepRes)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException AddDepRes))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$
          PackageName
-> PackageInfo
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
addDep PackageName
name PackageInfo
packageInfo
  PackageName
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
  Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
addDep PackageName
name PackageInfo
packageInfo = do
  Text
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"addDep" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Package info for "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName 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 :: WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe PackageLocationImmutable)
askPkgLoc = RIO Ctx (Maybe PackageLocationImmutable)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe PackageLocationImmutable)
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m) =>
RIO env a -> m a
liftRIO (RIO Ctx (Maybe PackageLocationImmutable)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe PackageLocationImmutable))
-> RIO Ctx (Maybe PackageLocationImmutable)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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.

                Maybe (NonEmpty PackageName)
cs <- (Ctx -> Maybe (NonEmpty PackageName))
-> RIO Ctx (Maybe (NonEmpty PackageName))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([PackageName] -> Maybe (NonEmpty PackageName)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([PackageName] -> Maybe (NonEmpty PackageName))
-> (Ctx -> [PackageName]) -> Ctx -> Maybe (NonEmpty PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.callStack))
                [PackageName]
cs' <- RIO Ctx [PackageName]
-> (NonEmpty PackageName -> RIO Ctx [PackageName])
-> Maybe (NonEmpty PackageName)
-> RIO Ctx [PackageName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  (BuildException -> RIO Ctx [PackageName]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BuildException
CallStackEmptyBug)
                  ([PackageName] -> RIO Ctx [PackageName]
forall a. a -> RIO Ctx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageName] -> RIO Ctx [PackageName])
-> (NonEmpty PackageName -> [PackageName])
-> NonEmpty PackageName
-> RIO Ctx [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PackageName -> [PackageName]
forall a. NonEmpty a -> [a]
NE.tail)
                  Maybe (NonEmpty PackageName)
cs
                [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 (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName 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 PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName [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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutablesUpstream PackageName
name WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe PackageLocationImmutable)
askPkgLoc InstallLocation
loc Map FlagName Bool
forall k a. Map k a
Map.empty
      Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutables PackageName
name PackageSource
ps
      PackageName
-> PackageSource
-> Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
forall a. Maybe a
Nothing
    PIBoth PackageSource
ps Installed
installed -> do
      PackageName
-> PackageSource
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutables PackageName
name PackageSource
ps
      PackageName
-> PackageSource
-> Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps (Installed -> Maybe Installed
forall a. a -> Maybe a
Just Installed
installed)

-- | For given 'PackageName' and 'PackageSource' values, adds relevant

-- executables to the collected output.

tellExecutables :: PackageName -> PackageSource -> M ()
tellExecutables :: PackageName
-> PackageSource
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutables PackageName
_name (PSFilePath LocalPackage
lp)
  | LocalPackage
lp.wanted = InstallLocation
-> Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutablesPackage InstallLocation
Local LocalPackage
lp.package
  | Bool
otherwise = ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutablesUpstream PackageName
name (Maybe PackageLocationImmutable
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe PackageLocationImmutable)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just PackageLocationImmutable
pkgloc) InstallLocation
Snap CommonPackage
cp.flags

-- | For a given 'PackageName' value, known to be immutable, adds relevant

-- executables to the collected output.

tellExecutablesUpstream ::
     PackageName
  -> M (Maybe PackageLocationImmutable)
  -> InstallLocation
  -> Map FlagName Bool
  -> M ()
tellExecutablesUpstream :: PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutablesUpstream PackageName
name WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe PackageLocationImmutable)
retrievePkgLoc InstallLocation
loc Map FlagName Bool
flags = do
  Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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
ctx.wanted) (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   ()
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe PackageLocationImmutable
mPkgLoc <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe PackageLocationImmutable)
retrievePkgLoc
    Maybe PackageLocationImmutable
-> (PackageLocationImmutable
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         ())
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PackageLocationImmutable
mPkgLoc ((PackageLocationImmutable
  -> WriterT
       W
       (StateT
          (Map PackageName (Either ConstructPlanException AddDepRes))
          (RIO Ctx))
       ())
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> (PackageLocationImmutable
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         ())
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$ \PackageLocationImmutable
pkgLoc -> do
      Package
p <- Ctx
ctx.loadPackage PackageLocationImmutable
pkgLoc Map FlagName Bool
flags [] []
      InstallLocation
-> Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutablesPackage InstallLocation
loc Package
p

-- | For given 'InstallLocation' and 'Package' values, adds relevant executables

-- to the collected output. In most cases, the relevant executables are all the

-- executables of the package. If the package is a wanted local one, the

-- executables are those executables that are wanted executables.

tellExecutablesPackage :: InstallLocation -> Package -> M ()
tellExecutablesPackage :: InstallLocation
-> Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
tellExecutablesPackage InstallLocation
loc Package
p = do
  Map PackageName PackageInfo
cm <- (Ctx -> Map PackageName PackageInfo)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Map PackageName PackageInfo)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.combinedMap)
  -- Determine which components are enabled so we know which ones to copy

  let myComps :: Set Text
myComps =
        case PackageName -> Map PackageName PackageInfo -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Package
p.name Map PackageName PackageInfo
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
lp.wanted = Set NamedComponent -> Set Text
exeComponents LocalPackage
lp.components
        | Bool
otherwise = Set Text
forall a. Set a
Set.empty
      goSource PSRemote{} = Set Text
forall a. Set a
Set.empty

  W
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty
    { wInstall = Map.fromList $
        map (, loc) $ Set.toList $ filterComps myComps $ buildableExes 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
minstalled = do
  Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  case PackageSource
ps of
    PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
cp -> do
      Text
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"."
      Package
package <- Ctx
ctx.loadPackage
        PackageLocationImmutable
pkgLoc CommonPackage
cp.flags CommonPackage
cp.ghcOptions CommonPackage
cp.cabalConfigOpts
      Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
True CommonPackage
cp.buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled
    PSFilePath LocalPackage
lp -> do
      case LocalPackage
lp.testBench of
        Maybe Package
Nothing -> do
          Text
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"No test or bench component for "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall
            Bool
True LocalPackage
lp.buildHaddocks PackageSource
ps LocalPackage
lp.package 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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Map PackageName (Either ConstructPlanException AddDepRes))
forall s (m :: * -> *). MonadState s m => m s
get
          Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
   W -> W)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (a, W -> W)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   (Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
    W -> W)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
      W -> W)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
                   Utf8Builder
"For "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName 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
forall {r}.
(HasField "expectTestFailure" r (Set PackageName),
 HasField "expectBenchmarkFailure" r (Set PackageName)) =>
Maybe r -> Bool
expectedTestOrBenchFailures (Maybe Curator -> Bool)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Curator)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ctx -> Maybe Curator)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Curator)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.curator)
              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
lp.buildHaddocks 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
addFinal LocalPackage
lp Package
tb Bool
finalAllInOne Bool
False
              Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall env (m :: * -> *).
(?callStack::CallStack, HasRunner env, MonadIO m,
 MonadReader env m) =>
Text -> Utf8Builder -> m ()
logDebugPlanS Text
"installPackage" (Utf8Builder
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> Utf8Builder
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall
                Bool
False LocalPackage
lp.buildHaddocks PackageSource
ps LocalPackage
lp.package Maybe Installed
minstalled
              Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either ConstructPlanException AddDepRes -> Bool
forall a b. Either a b -> Bool
isRight Either ConstructPlanException AddDepRes
res') (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   ()
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$ do
                -- Insert it into the map so that it's available for addFinal.

                PackageName
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res'
                LocalPackage
-> Package
-> Bool
-> Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
addFinal LocalPackage
lp Package
tb Bool
False Bool
False
              Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res'
 where
  expectedTestOrBenchFailures :: Maybe r -> Bool
expectedTestOrBenchFailures Maybe r
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
    r
curator <- Maybe r
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 r
curator.expectTestFailure
         Bool -> Bool -> Bool
|| PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name r
curator.expectBenchmarkFailure

resolveDepsAndInstall ::
     Bool
     -- ^ will the build step also build any tests?

  -> Bool
     -- ^ Should Haddock documentation be built?

  -> PackageSource
  -> Package
  -> Maybe Installed
  -> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConstructPlanException AddDepRes
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
     -- ^ will the build step also build any tests?

  -> Bool
     -- ^ Should Haddock documentation be built?

  -> 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
package.name
    Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks
        Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Installed)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Installed
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe Installed))
-> Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty
          { wDirty =
              Map.singleton name $ "missing dependencies: " <> addEllipsis t
          }
        Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Installed)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
      (Maybe Installed
Nothing, Bool
_) -> Maybe Installed
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Installed)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
        { $sel:configOpts:Task :: TaskConfigOpts
configOpts = 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.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
ctx.baseConfigOpts
                  Map PackageIdentifier GhcPkgId
allDeps
                  (PackageSource -> Bool
psLocal PackageSource
ps)
                  IsMutable
mutable
                  Package
package
        , Bool
$sel:buildHaddocks:Task :: Bool
buildHaddocks :: Bool
buildHaddocks
        , Map PackageIdentifier GhcPkgId
$sel:present:Task :: Map PackageIdentifier GhcPkgId
present :: Map PackageIdentifier GhcPkgId
present
        , $sel:taskType:Task :: 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
        , $sel:allInOne:Task :: Bool
allInOne = Bool
isAllInOne
        , $sel:cachePkgSrc:Task :: CachePkgSrc
cachePkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
        , $sel:buildTypeConfig:Task :: Bool
buildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
        }

-- | Is the build type of the package Configure

packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig Package
pkg = Package
pkg.buildType 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
val = (Map PackageName (Either ConstructPlanException AddDepRes)
 -> Map PackageName (Either ConstructPlanException AddDepRes))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map PackageName (Either ConstructPlanException AddDepRes)
  -> Map PackageName (Either ConstructPlanException AddDepRes))
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> (Map PackageName (Either ConstructPlanException AddDepRes)
    -> Map PackageName (Either ConstructPlanException AddDepRes))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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 resulting

-- triple indicates: (1) which packages are missing. This means that their

-- 'GhcPkgId's will be figured out during the build, after they've been built;

-- (2) the packages that are already installed and which will be used; and

-- (3) whether the package itself is mutable or immutable.

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
  Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
checkAndWarnForUnknownTools Package
package
  let pkgId :: PackageIdentifier
pkgId = Package -> PackageIdentifier
packageIdentifier Package
package
  [Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
deps <- Package
-> (PackageName
    -> DepValue
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Either
            (PackageName,
             (VersionRange, Maybe (Version, BlobKey), BadDependency))
            (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
             IsMutable)))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
forall (m :: * -> *) resT.
Monad m =>
Package -> (PackageName -> DepValue -> m resT) -> m [resT]
processPackageDepsToList Package
package (PackageIdentifier
-> PackageName
-> DepValue
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
processDep PackageIdentifier
pkgId)
  Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
$ 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 'IsMutable' means that if any is 'Mutable',

    -- the result is 'Mutable'. Otherwise the result is 'Immutable'.

    ([], [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
pairs) -> (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)]
_) ->
      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)

-- | Given a dependency, yields either information for an error message or a

-- triple indicating: (1) if the dependency is to be installed, its package

-- identifier; (2) if the dependency is installed and a library, its package

-- identifier and 'GhcPkgId'; and (3) if the dependency is, or will be when

-- installed, mutable or immutable.

processDep ::
     PackageIdentifier
     -- ^ The package which has the dependency being processed.

  -> PackageName
     -- ^ The name of the dependency.

  -> DepValue
     -- ^ The version range and dependency type of the dependency.

  -> M ( Either
           ( PackageName
           , (VersionRange, Maybe (Version, BlobKey), BadDependency)
           )
           (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
       )
processDep :: PackageIdentifier
-> PackageName
-> DepValue
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
processDep PackageIdentifier
pkgId PackageName
name DepValue
value = do
  Maybe (Version, BlobKey)
mLatestApplicable <- PackageName -> VersionRange -> M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev PackageName
name VersionRange
range
  Either ConstructPlanException AddDepRes
eRes <- PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep PackageName
name
  case Either ConstructPlanException AddDepRes
eRes of
    Left ConstructPlanException
e -> do
      WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
addParent
      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
name) 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 Version
version
      Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (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)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
name, (VersionRange
range, Maybe (Version, BlobKey)
mLatestApplicable, BadDependency
bd))
    Right AddDepRes
adr
      | DepType -> Bool
isDepTypeLibrary DepValue
value.depType Bool -> Bool -> Bool
&& Bool -> Bool
not (AddDepRes -> Bool
adrHasLibrary AddDepRes
adr) ->
          Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (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)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
name, (VersionRange
range, Maybe (Version, BlobKey)
forall a. Maybe a
Nothing, BadDependency
HasNoLibrary))
    Right AddDepRes
adr -> do
      WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
addParent
      Bool
inRange <- PackageIdentifier
-> PackageName
-> VersionRange
-> AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
adrInRange PackageIdentifier
pkgId PackageName
name VersionRange
range AddDepRes
adr
      Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (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)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ if Bool
inRange
        then (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, Map PackageIdentifier GhcPkgId, IsMutable)
 -> Either
      (PackageName,
       (VersionRange, Maybe (Version, BlobKey), BadDependency))
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. (a -> b) -> a -> b
$ AddDepRes
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
processAdr AddDepRes
adr
        else (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
name
          , ( 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
            )
          )
 where
  range :: VersionRange
range = DepValue
value.versionRange
  version :: Version
version = PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkgId
  -- Update the parents map, for later use in plan construction errors

  -- - see 'getShortestDepsPath'.

  addParent :: WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
addParent =
    let parentMap :: Map PackageName [(PackageIdentifier, VersionRange)]
parentMap = PackageName
-> [(PackageIdentifier, VersionRange)]
-> Map PackageName [(PackageIdentifier, VersionRange)]
forall k a. k -> a -> Map k a
Map.singleton PackageName
name [(PackageIdentifier
pkgId, VersionRange
range)]
    in  W
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wParents = MonoidMap parentMap }

getLatestApplicableVersionAndRev ::
     PackageName
  -> VersionRange
  -> M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev :: PackageName -> VersionRange -> M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev PackageName
name VersionRange
range = do
  Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Map Version (Map Revision BlobKey)
vsAndRevs <- Ctx
-> RIO Ctx (Map Version (Map Revision BlobKey))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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))
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Map Version (Map Revision BlobKey)))
-> RIO Ctx (Map Version (Map Revision BlobKey))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
name
  Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey))
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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)

-- | Function to determine whether the result of 'addDep' is within range, given

-- the version range of the dependency and taking into account Stack's

-- @allow-newer@ configuration.

adrInRange ::
     PackageIdentifier
     -- ^ The package which has the dependency.

  -> PackageName
     -- ^ The name of the dependency.

  -> VersionRange
     -- ^ The version range of the dependency.

  -> AddDepRes
     -- ^ The result of 'addDep'.

  -> M Bool
adrInRange :: PackageIdentifier
-> PackageName
-> VersionRange
-> AddDepRes
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
adrInRange PackageIdentifier
pkgId PackageName
name VersionRange
range AddDepRes
adr = if AddDepRes -> Version
adrVersion AddDepRes
adr Version -> VersionRange -> Bool
`withinRange` VersionRange
range
  then Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  else do
    Bool
allowNewer <- Getting Bool Ctx Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool Ctx Bool
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      Bool)
-> Getting Bool Ctx Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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 (.allowNewer)
    Maybe [PackageName]
allowNewerDeps <- Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe [PackageName])
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe [PackageName]))
-> Getting (Maybe [PackageName]) Ctx (Maybe [PackageName])
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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 (.allowNewerDeps)
    if Bool
allowNewer
      then case Maybe [PackageName]
allowNewerDeps of
        Maybe [PackageName]
Nothing -> do
          Bool
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True (StyleDoc
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
            [StyleDoc] -> StyleDoc
fillSep
              [ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
              , StyleDoc
"enabled"
              ]
          Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just [PackageName]
boundsIgnoredDeps -> do
          let pkgName' :: StyleDoc
pkgName' = PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName 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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
isBoundsIgnoreDep StyleDoc
reason
          Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBoundsIgnoreDep
      else do
        Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe [PackageName] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [PackageName]
allowNewerDeps) (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   ()
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a b. (a -> b) -> a -> b
$
          Bool
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
False (StyleDoc
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      ())
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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"
              ]
        -- We ignore dependency information for packages in a snapshot

        Bool
pkgInSnapshot <- PackageName
-> Version
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
inSnapshot PackageName
pkgName Version
version
        Bool
adrInSnapshot <- PackageName
-> Version
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
inSnapshot PackageName
name (AddDepRes -> Version
adrVersion AddDepRes
adr)
        if Bool
pkgInSnapshot Bool -> Bool -> Bool
&& Bool
adrInSnapshot
          then do
            Bool
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True
              ( [Char] -> StyleDoc
flow [Char]
"trusting snapshot over Cabal file dependency \
                     \information"
              )
            Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
 where
  PackageIdentifier PackageName
pkgName Version
version = PackageIdentifier
pkgId
  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 = (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 (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkgName) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"'s"
            , [Char] -> StyleDoc
flow [Char]
"bounds on"
            , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name)
            , 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
                (PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name (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
"."
            ]

-- | Given a result of 'addDep', yields a triple indicating: (1) if the

-- dependency is to be installed, its package identifier; (2) if the dependency

-- is installed and a library, its package identifier and 'GhcPkgId'; and (3) if

-- the dependency is, or will be when installed, mutable or immutable.

processAdr ::
     AddDepRes
  -> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
processAdr :: AddDepRes
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
processAdr AddDepRes
adr = case AddDepRes
adr of
  ADRToInstall Task
task ->
    (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
_) ->
    (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 InstalledLibraryInfo
installedInfo) ->
    ( Set PackageIdentifier
forall a. Set a
Set.empty
    , PackageIdentifier
-> InstalledLibraryInfo -> Map PackageIdentifier GhcPkgId
installedMapGhcPkgId PackageIdentifier
ident InstalledLibraryInfo
installedInfo
    , InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc
    )

checkDirtiness ::
     PackageSource
  -> Installed
  -> Package
  -> Map PackageIdentifier GhcPkgId
  -> Bool
     -- ^ Is Haddock documentation being built?

  -> M Bool
checkDirtiness :: PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks = do
  Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe ConfigCache
moldOpts <- Ctx
-> RIO Ctx (Maybe ConfigCache)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ConfigCache)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx (RIO Ctx (Maybe ConfigCache)
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe ConfigCache))
-> RIO Ctx (Maybe ConfigCache)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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 configureOpts :: ConfigureOpts
configureOpts = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
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
ctx.baseConfigOpts
        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
      components :: Set ByteString
components = 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) LocalPackage
lp.components
        PSRemote{} -> Set ByteString
forall a. Set a
Set.empty
      wantConfigCache :: ConfigCache
wantConfigCache = ConfigCache
        { ConfigureOpts
configureOpts :: ConfigureOpts
$sel:configureOpts:ConfigCache :: ConfigureOpts
configureOpts
        , $sel:deps:ConfigCache :: Set GhcPkgId
deps = [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
        , Set ByteString
components :: Set ByteString
$sel:components:ConfigCache :: Set ByteString
components
        , Bool
buildHaddocks :: Bool
$sel:buildHaddocks:ConfigCache :: Bool
buildHaddocks
        , $sel:pkgSrc:ConfigCache :: CachePkgSrc
pkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
        , $sel:pathEnvVar:ConfigCache :: Text
pathEnvVar = Ctx
ctx.pathEnvVar
        }
      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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Text)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe Text))
-> Maybe Text
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Text)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe Text))
-> Maybe Text
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Text)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe Text))
-> Maybe Text
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe (Set [Char]))
forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set [Char]))
psDirty PackageSource
ps
            Maybe Text
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Text)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe Text))
-> Maybe Text
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (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
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Text
reason -> do
      W
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wDirty = Map.singleton package.name reason }
      Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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
old.pkgSrc CachePkgSrc -> CachePkgSrc -> Bool
forall a. Eq a => a -> a -> Bool
/= ConfigCache
new.pkgSrc = 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
old.pkgSrc 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
new.pkgSrc
  | Bool -> Bool
not (ConfigCache
new.deps Set GhcPkgId -> Set GhcPkgId -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` ConfigCache
old.deps) =
      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
old.buildHaddocks Bool -> Bool -> Bool
&& ConfigCache
new.buildHaddocks =
      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
config.rebuildGhcOptions
                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
. (.configureOpts)
   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
new.components Set ByteString -> Set ByteString -> Set ByteString
forall {a}. Ord a => Set a -> Set a -> Set a
`Set.difference` ConfigCache
old.components

  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
lp.forceDirty
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 LocalPackage
lp.dirtyFiles
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

-- | For the given package, warn about any unknown tools that are not on the

-- PATH and not one of the executables of the package.

checkAndWarnForUnknownTools :: Package -> M ()
checkAndWarnForUnknownTools :: Package
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
checkAndWarnForUnknownTools Package
p = do
  let unknownTools :: [Text]
unknownTools = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageUnknownTools Package
p
  -- Check whether the tool is on the PATH or a package executable before

  -- warning about it.

  [ToolWarning]
warnings <-
    ([Maybe ToolWarning] -> [ToolWarning])
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [Maybe ToolWarning]
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [ToolWarning]
forall a b.
(a -> b)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ToolWarning] -> [ToolWarning]
forall a. [Maybe a] -> [a]
catMaybes (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   [Maybe ToolWarning]
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      [ToolWarning])
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [Maybe ToolWarning]
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [ToolWarning]
forall a b. (a -> b) -> a -> b
$ [Text]
-> (Text
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Maybe ToolWarning))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [Maybe ToolWarning]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
unknownTools ((Text
  -> WriterT
       W
       (StateT
          (Map PackageName (Either ConstructPlanException AddDepRes))
          (RIO Ctx))
       (Maybe ToolWarning))
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      [Maybe ToolWarning])
-> (Text
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Maybe ToolWarning))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     [Maybe ToolWarning]
forall a b. (a -> b) -> a -> b
$ \Text
toolName ->
      MaybeT
  (WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx)))
  ToolWarning
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ToolWarning)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx)))
   ToolWarning
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe ToolWarning))
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ToolWarning)
forall a b. (a -> b) -> a -> b
$ Text
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
forall {s} {m :: * -> *}.
(MonadReader s m, MonadIO m, HasConfig s) =>
Text -> MaybeT m ()
notOnPath Text
toolName MaybeT
  (WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx)))
  ()
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
forall a b.
MaybeT
  (WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx)))
  a
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     b
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
forall {m :: * -> *}. Applicative m => Text -> MaybeT m ()
notPackageExe Text
toolName MaybeT
  (WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx)))
  ()
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
forall a b.
MaybeT
  (WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx)))
  a
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     b
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
forall {m :: * -> *}. Applicative m => Text -> MaybeT m ToolWarning
warn Text
toolName
  W
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wWarnings = (map toolWarningText warnings ++) }
  ()
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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 { includeLocals = 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
config.processContextSettings 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 -> CompCollection StackExecutable -> Bool
forall component. Text -> CompCollection component -> Bool
collectionMember Text
toolName Package
p.executables
  warn :: Text -> MaybeT m ToolWarning
warn Text
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 (Text -> ExeName
ExeName Text
name) Package
p.name
  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 ()

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 (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkgName')
  ]

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

-- database?

inSnapshot :: PackageName -> Version -> M Bool
inSnapshot :: PackageName
-> Version
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
inSnapshot PackageName
name Version
version = do
  Ctx
ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     Bool
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      Bool)
-> Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     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 -> Map PackageName PackageInfo -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Ctx
ctx.combinedMap
    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 InstalledLibraryInfo
_) ->
        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 (.planInLog)
  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

-- | A function to yield a 'PackageInfo' value from: (1) a 'PackageSource'

-- value; and (2) a pair of an 'InstallLocation' value and an 'Installed' value.

-- Checks that the version of the 'PackageSource' value and the version of the

-- `Installed` value are the same.

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

-- | A function to yield a 'CombinedMap' value from: (1) a dictionary of package

-- names, and where the source code of the named package is located; and (2) an

-- 'InstalledMap' value.

combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap :: Map PackageName PackageSource
-> InstalledMap -> Map PackageName PackageInfo
combineMap = SimpleWhenMissing PackageName PackageSource PackageInfo
-> SimpleWhenMissing
     PackageName (InstallLocation, Installed) PackageInfo
-> SimpleWhenMatched
     PackageName PackageSource (InstallLocation, Installed) PackageInfo
-> Map PackageName PackageSource
-> InstalledMap
-> Map PackageName PackageInfo
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))