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

{-|
Module      : Stack.Build.ConstructPlan
Description : Construct a @Plan@ for how to build.
License     : BSD-3-Clause

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           Distribution.Version ( mkVersion )
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.ConfigureOpts
                   ( configureOptsFromBase, packageConfigureOptsFromPackage
                   , renderConfigureOpts
                   )
import           Stack.Constants ( compilerOptionsCabalFlag )
import           Stack.Package
                   ( applyForceCustomBuild, buildableExes, packageUnknownTools
                   , processPackageDepsEither
                   )
import           Stack.Prelude hiding ( loadPackage )
import           Stack.SourceMap ( getPLIVersion, mkProjectPackage )
import           Stack.Types.Build.ConstructPlan
                   ( AddDepRes (..), CombinedMap, Ctx (..), M
                   , MissingPresentDeps (..), PackageInfo (..), ToolWarning(..)
                   , UnregisterState (..), W (..), adrHasLibrary, adrVersion
                   , isAdrToInstall, toTask
                   )
import           Stack.Types.Build.Exception
                   ( BadDependency (..), BuildException (..)
                   , BuildPrettyException (..), ConstructPlanException (..)
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), configFileL )
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), BuildSubset (..) )
import           Stack.Types.Cache ( CachePkgSrc (..), ConfigCache (..) )
import           Stack.Types.CompCollection ( collectionMember )
import           Stack.Types.Compiler ( WhichCompiler (..), getGhcVersion )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..) )
import           Stack.Types.ComponentUtils ( unqualCompFromText )
import           Stack.Types.Config ( Config (..), HasConfig (..), stackRootL )
import           Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
import           Stack.Types.Curator ( Curator (..) )
import           Stack.Types.Dependency ( DepValue (..), isDepTypeLibrary )
import           Stack.Types.DumpPackage ( DumpPackage (..), sublibParentPkgId )
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.Plan
                   ( Plan (..), Task (..), TaskConfigOpts (..), TaskType (..)
                   , installLocationIsMutable, taskIsTarget, taskLocation
                   , taskProvides, taskTargetIsMutable
                   )
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 t'Task's to

-- take, and the interdependencies among the build t'Task's. In particular:

--

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

-- deps of the current targets. For project packages, this is indicated by the

-- 'Stack.Types.Package.wanted' 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"

    config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
    let ghcVersion = ActualCompiler -> Version
getGhcVersion SourceMap
sourceMap.compiler
        isBaseWiredIn = Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
9,Int
12]
    when (hasBaseInDeps && (isBaseWiredIn || config.notifyIfBaseNotBoot)) $ do
      let intro = [StyleDoc] -> StyleDoc
fillSep
            [ [Char] -> StyleDoc
flow [Char]
"Before GHC 9.12.1, the base package is a GHC wired-in \
                   \one. For other GHC versions it is not. You are using"
            , Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc
"GHC " StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
ghcVersion)
            , [Char] -> StyleDoc
flow [Char]
"and trying to replace its"
            , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
            , [Char] -> StyleDoc
flow [Char]
"boot package."
            ]
          adviceInit = if Bool
isBaseWiredIn
            then
              [ [Char] -> StyleDoc
flow [Char]
"Almost certainly, that is not what you really want to \
                     \do. Consider removing"
              ]
            else
              [ [Char] -> StyleDoc
flow [Char]
"That may be not what you want to do. If not, consider \
                     \removing"
              ]
          adviceRest =
            [ 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]
"or, if you need a particular 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]
"consider using a different GHC version."
            ]
          adviceMute = [StyleDoc] -> StyleDoc
fillSep
            [ [Char] -> StyleDoc
flow [Char]
"To mute this message in future, set"
            , Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
flow [Char]
"notify-if-base-not-boot: false")
            , [Char] -> StyleDoc
flow [Char]
"in Stack's configuration."
            ]
      prettyWarn $
           intro
        <> blankLine
        <> fillSep (adviceInit <> adviceRest)
        <> (if isBaseWiredIn then mempty else blankLine <> adviceMute)
        <> line

    econfig <- view envConfigL
    globalCabalVersion <- view $ compilerPathsL . to (.cabalVersion)
    sources <- getSources globalCabalVersion
    curator <- view $ buildConfigL . to (.curator)
    pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
    let 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 = Map PackageName Target -> [PackageName]
forall k a. Map k a -> [k]
Map.keys SourceMap
sourceMap.targets.targets
        -- Ignore the result of 'getCachedDepOrAddDep'.

        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 = (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 efinals installExes dirtyReason warnings parents), m) <-
      liftIO $ runRIO ctx (runStateT (runWriterT inner) Map.empty)
    -- Report any warnings

    mapM_ prettyWarn (warnings [])
    -- Separate out errors

    let (errlibs, adrs) = partitionEithers $ map toEither $ Map.toList m
        (errfinals, finals) =
          partitionEithers $ map toEither $ Map.toList efinals
        errs = [ConstructPlanException]
errlibs [ConstructPlanException]
-> [ConstructPlanException] -> [ConstructPlanException]
forall a. [a] -> [a] -> [a]
++ [ConstructPlanException]
errfinals
    if null errs
      then do
        let 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
        takeSubset Plan
          { tasks = tasks
          , finals = Map.fromList finals
          , unregisterLocal =
              mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps
          , installExes =
              if    baseConfigOpts0.buildOpts.installExes
                 || baseConfigOpts0.buildOpts.installCompilerTool
                then installExes
                else Map.empty
          }
      else do
        configFile <- view configFileL
        stackRoot <- view stackRootL
        isImplicitGlobal <-
          view $ configL . to (isPCGlobalProject . (.project))
        prettyThrowM $ ConstructPlanFailed
          errs
          configFile
          stackRoot
          isImplicitGlobal
          parents
          ctx.wanted
          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) ()
collectMissing [PackageIdentifier]
forall a. Monoid a => a
mempty (Task -> PackageIdentifier
taskProvides Task
task)
    collectMissing :: [PackageIdentifier]
-> PackageIdentifier -> State (Set PackageIdentifier) ()
collectMissing [PackageIdentifier]
dependents PackageIdentifier
pid = do
      Bool
-> State (Set PackageIdentifier) ()
-> State (Set PackageIdentifier) ()
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) (State (Set PackageIdentifier) ()
 -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
-> State (Set PackageIdentifier) ()
forall a b. (a -> b) -> a -> b
$
        BuildException -> State (Set PackageIdentifier) ()
forall e a. Exception e => e -> a
impureThrow (BuildException -> State (Set PackageIdentifier) ())
-> BuildException -> State (Set PackageIdentifier) ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
TaskCycleBug PackageIdentifier
pid
      (Set PackageIdentifier -> Set PackageIdentifier)
-> State (Set PackageIdentifier) ()
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 -> State (Set PackageIdentifier) ())
-> Set PackageIdentifier -> State (Set PackageIdentifier) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        ([PackageIdentifier]
-> PackageIdentifier -> State (Set PackageIdentifier) ()
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 StackUnqualCompName 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 :: [StackUnqualCompName]
snapExes = Map StackUnqualCompName InstallLocation -> [StackUnqualCompName]
forall k a. Map k a -> [k]
Map.keys (Map StackUnqualCompName InstallLocation -> [StackUnqualCompName])
-> Map StackUnqualCompName InstallLocation -> [StackUnqualCompName]
forall a b. (a -> b) -> a -> b
$ (InstallLocation -> Bool)
-> Map StackUnqualCompName InstallLocation
-> Map StackUnqualCompName 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 StackUnqualCompName 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
&& [StackUnqualCompName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StackUnqualCompName]
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] -> [StackUnqualCompName] -> BuildPrettyException
NotOnlyLocal [PackageName]
snapTasks [StackUnqualCompName]
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
          lp <- ProjectPackage -> RIO env LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage ProjectPackage
pp
          let lpPackage' =
                Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion LocalPackage
lp.package
          pure lp { package = lpPackage' }
    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
      lp <- ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
      pure $ PSFilePath lp
    bopts <- view $ configL . to (.build)
    deps <- for sourceDeps $ \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
          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)
          lp <- loadLocalPackage' pp
          pure $ PSFilePath lp
    pure $ pPackages <> deps

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

-- already registered project packages and local extra-deps.

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
    us <- StateT UnregisterState Identity UnregisterState
forall s (m :: * -> *). MonadState s m => m s
get
    case maybeUnregisterReason us.toUnregister ident mParentLibId 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
sublibParentPkgId 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 t'LocalPackage' and its 'testBench', adds a t'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
allInOne Bool
buildHaddocks = do
  res <- Package -> M (Either ConstructPlanException MissingPresentDeps)
addPackageDeps Package
package M (Either ConstructPlanException MissingPresentDeps)
-> (Either ConstructPlanException MissingPresentDeps
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Either ConstructPlanException Task))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException Task)
forall a b.
WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  a
-> (a
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         b)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    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 (MissingPresentDeps Set PackageIdentifier
missing Map PackageIdentifier GhcPkgId
present IsMutable
_minLoc) -> do
      let pkgConfigOpts :: PackageConfigureOpts
pkgConfigOpts = Package -> PackageConfigureOpts
packageConfigureOptsFromPackage Package
package
      ctx <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
      let configOpts = TaskConfigOpts
            { Set PackageIdentifier
missing :: Set PackageIdentifier
missing :: Set PackageIdentifier
missing
            , envConfig :: EnvConfig
envConfig = Ctx
ctx.ctxEnvConfig
            , baseConfigOpts :: BaseConfigOpts
baseConfigOpts = Ctx
ctx.baseConfigOpts
            , isLocalNonExtraDep :: Bool
isLocalNonExtraDep = Bool
True
            , isMutable :: IsMutable
isMutable = IsMutable
Mutable
            , PackageConfigureOpts
pkgConfigOpts :: PackageConfigureOpts
pkgConfigOpts :: PackageConfigureOpts
pkgConfigOpts
            }
      pure $ Right Task
        { configOpts
        , buildHaddocks
        , present
        , taskType = TTLocalMutable lp
        , allInOne
        , cachePkgSrc = CacheSrcLocal (toFilePath (parent lp.cabalFP))
        , buildTypeConfig = packageBuildTypeConfig package
        }
  tell 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
  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 Map.lookup name 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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  let compiler = Ctx
ctx.ctxEnvConfig.sourceMap.compiler
  res <- if name `elem` ctx.callStack
    then do
      logDebugPlanS "checkCallStackAndAddDep" $
           "Detected cycle "
        <> fromPackageName name
        <> ": "
        <> fromString (show $ map packageNameString ctx.callStack)
      pure $ Left $ DependencyCycleDetected $ name : ctx.callStack
    else case Map.lookup name 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
$ ActualCompiler -> PackageName -> ConstructPlanException
UnknownPackage ActualCompiler
compiler 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
  updateLibMap name res
  pure 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
$
            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 RIO Ctx (Maybe (Revision, BlobKey, TreeKey))
-> (Maybe (Revision, BlobKey, TreeKey)
    -> RIO Ctx (Maybe PackageLocationImmutable))
-> RIO Ctx (Maybe PackageLocationImmutable)
forall a b. RIO Ctx a -> (a -> RIO Ctx b) -> RIO Ctx b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe (Revision, BlobKey, TreeKey)
Nothing -> do
                -- This could happen for GHC boot libraries missing from

                -- Hackage.

                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))
                cs' <- maybe
                  (throwIO CallStackEmptyBug)
                  (pure . NE.tail)
                  cs
                prettyWarnL
                  $ flow "No latest package revision found for"
                  : style Current (fromPackageName name) <> ","
                  : flow "dependency callstack:"
                  : mkNarrativeList Nothing False
                      (map fromPackageName cs' :: [StyleDoc])
                pure 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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  when (name `Set.member` ctx.wanted) $ do
    mPkgLoc <- retrievePkgLoc
    forM_ mPkgLoc $ \PackageLocationImmutable
pkgLoc -> do
      p <- Ctx
ctx.loadPackage PackageLocationImmutable
pkgLoc Map FlagName Bool
flags [] []
      tellExecutablesPackage loc p

-- | For given 'InstallLocation' and t'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
  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 =
        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 StackUnqualCompName -> Set StackUnqualCompName
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Set StackUnqualCompName
forall a. Set a
Set.empty
          Just (PIOnlyInstalled InstallLocation
_ Installed
_) -> Set StackUnqualCompName
forall a. Set a
Set.empty
          Just (PIOnlySource PackageSource
ps) -> PackageSource -> Set StackUnqualCompName
goSource PackageSource
ps
          Just (PIBoth PackageSource
ps Installed
_) -> PackageSource -> Set StackUnqualCompName
goSource PackageSource
ps

      goSource (PSFilePath LocalPackage
lp)
        | LocalPackage
lp.wanted = Set NamedComponent -> Set StackUnqualCompName
exeComponents LocalPackage
lp.components
        | Bool
otherwise = Set StackUnqualCompName
forall a. Set a
Set.empty
      goSource PSRemote{} = Set StackUnqualCompName
forall a. Set a
Set.empty

  tell 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 t'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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  case 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 <- Ctx
ctx.loadPackage
        PackageLocationImmutable
pkgLoc CommonPackage
cp.flags CommonPackage
cp.ghcOptions CommonPackage
cp.cabalConfigOpts
      resolveDepsAndInstall True cp.buildHaddocks ps package 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.

          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
          res <- pass $ do
            res <- addPackageDeps tb
            let writerFunc W
w = case Either ConstructPlanException MissingPresentDeps
res of
                  Left ConstructPlanException
_ -> W
forall a. Monoid a => a
mempty
                  Either ConstructPlanException MissingPresentDeps
_ -> W
w
            pure (res, writerFunc)
          case res of
            Right MissingPresentDeps
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

              splitRequired <- Maybe Curator -> 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 -> Bool
not Bool
splitRequired
              adr <- installPackageGivenDeps
                isAllInOne lp.buildHaddocks ps tb minstalled deps
              let finalAllInOne = Bool -> Bool
not (AddDepRes -> Bool
isAdrToInstall AddDepRes
adr Bool -> Bool -> Bool
&& Bool
splitRequired)
              -- FIXME: this redundantly adds the deps (but they'll all just

              -- get looked up in the map)

              addFinal lp tb finalAllInOne False
              pure $ Right 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.

              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
              when (isRight res') $ do
                -- Insert it into the map so that it's available for addFinal.

                updateLibMap name res'
                addFinal lp tb False False
              pure res'
 where
  expectedTestOrBenchFailures :: Maybe Curator -> Bool
expectedTestOrBenchFailures Maybe Curator
maybeCurator = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    curator <- Maybe Curator
maybeCurator
    pure $  Set.member name curator.expectTestFailure
         || Set.member name 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 =
  Package -> M (Either ConstructPlanException MissingPresentDeps)
addPackageDeps Package
package M (Either ConstructPlanException MissingPresentDeps)
-> (Either ConstructPlanException MissingPresentDeps
    -> 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.
WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  a
-> (a
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         b)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    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 MissingPresentDeps
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
-> MissingPresentDeps
-> M AddDepRes
installPackageGivenDeps
          Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled MissingPresentDeps
deps

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

-- 'addPackageDeps'. If dependencies are missing, the package is dirty, or it is

-- 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
  -> MissingPresentDeps
  -> M AddDepRes
installPackageGivenDeps :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> MissingPresentDeps
-> M AddDepRes
installPackageGivenDeps Bool
allInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled
  (MissingPresentDeps Set PackageIdentifier
missing Map PackageIdentifier GhcPkgId
present IsMutable
minMutable) = do
    let name :: PackageName
name = Package
package.name
    mRightVersionInstalled <- case Maybe Installed
minstalled of
      Just Installed
installed -> if Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
        then do
          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
          pure $ if shouldInstall then Nothing else Just installed
        else do
          let packageNameText :: PackageIdentifier -> Text
packageNameText = [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
              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 PackageIdentifier -> Text
packageNameText (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 -> 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
    ctx <- ask
    let loc = PackageSource -> InstallLocation
psLocation PackageSource
ps
        isMutable = InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc IsMutable -> IsMutable -> IsMutable
forall a. Semigroup a => a -> a -> a
<> IsMutable
minMutable
        pkgConfigOpts = Package -> PackageConfigureOpts
packageConfigureOptsFromPackage Package
package
        configOpts = TaskConfigOpts
            { Set PackageIdentifier
missing :: Set PackageIdentifier
missing :: Set PackageIdentifier
missing
            , envConfig :: EnvConfig
envConfig = Ctx
ctx.ctxEnvConfig
            , baseConfigOpts :: BaseConfigOpts
baseConfigOpts = Ctx
ctx.baseConfigOpts
            , isLocalNonExtraDep :: Bool
isLocalNonExtraDep = PackageSource -> Bool
psLocal PackageSource
ps
            , IsMutable
isMutable :: IsMutable
isMutable :: IsMutable
isMutable
            , PackageConfigureOpts
pkgConfigOpts :: PackageConfigureOpts
pkgConfigOpts :: PackageConfigureOpts
pkgConfigOpts
            }
    pure $ case mRightVersionInstalled of
      Just Installed
installed -> InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
      Maybe Installed
Nothing -> Task -> AddDepRes
ADRToInstall Task
        { TaskConfigOpts
configOpts :: TaskConfigOpts
configOpts :: TaskConfigOpts
configOpts
        , Bool
buildHaddocks :: Bool
buildHaddocks :: Bool
buildHaddocks
        , Map PackageIdentifier GhcPkgId
present :: Map PackageIdentifier GhcPkgId
present :: Map PackageIdentifier GhcPkgId
present
        , taskType :: TaskType
taskType =
            case PackageSource
ps of
              PSFilePath LocalPackage
lp ->
                LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
              PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
_cp ->
                IsMutable -> Package -> PackageLocationImmutable -> TaskType
TTRemotePackage IsMutable
isMutable Package
package PackageLocationImmutable
pkgLoc
        , Bool
allInOne :: Bool
allInOne :: Bool
allInOne
        , cachePkgSrc :: CachePkgSrc
cachePkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
        , buildTypeConfig :: 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 MissingPresentDeps)
addPackageDeps :: Package -> M (Either ConstructPlanException MissingPresentDeps)
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
  Package
-> (PackageName
    -> DepValue
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Either
            (Map
               PackageName
               (VersionRange, Maybe (Version, BlobKey), BadDependency))
            MissingPresentDeps))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (Map
           PackageName
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
        MissingPresentDeps)
forall (m :: * -> *) a b.
(Monad m, Monoid a, Monoid b) =>
Package
-> (PackageName -> DepValue -> m (Either a b)) -> m (Either a b)
processPackageDepsEither Package
package (PackageIdentifier
-> PackageName
-> DepValue
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (Map
           PackageName
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
        MissingPresentDeps)
processDep PackageIdentifier
pkgId) WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Either
     (Map
        PackageName
        (VersionRange, Maybe (Version, BlobKey), BadDependency))
     MissingPresentDeps)
-> (Either
      (Map
         PackageName
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
      MissingPresentDeps
    -> Either ConstructPlanException MissingPresentDeps)
-> M (Either ConstructPlanException MissingPresentDeps)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    -- Note that the Monoid for 'IsMutable' means that if any is 'Mutable',

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

    Right MissingPresentDeps
v -> MissingPresentDeps
-> Either ConstructPlanException MissingPresentDeps
forall a b. b -> Either a b
Right MissingPresentDeps
v
    Left Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
errs ->
      ConstructPlanException
-> Either ConstructPlanException MissingPresentDeps
forall a b. a -> Either a b
Left (ConstructPlanException
 -> Either ConstructPlanException MissingPresentDeps)
-> ConstructPlanException
-> Either ConstructPlanException MissingPresentDeps
forall a b. (a -> b) -> a -> b
$ Package
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> ConstructPlanException
DependencyPlanFailures Package
package Map
  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
           ( Map
               PackageName
               (VersionRange, Maybe (Version, BlobKey), BadDependency)
           )
           MissingPresentDeps
       )
processDep :: PackageIdentifier
-> PackageName
-> DepValue
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (Map
           PackageName
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
        MissingPresentDeps)
processDep PackageIdentifier
pkgId PackageName
name DepValue
value = do
  let failure :: Maybe (Version, BlobKey)
-> BadDependency
-> Either
     (Map
        PackageName
        (VersionRange, Maybe (Version, BlobKey), BadDependency))
     MissingPresentDeps
failure Maybe (Version, BlobKey)
mLatestApp BadDependency
err =
        Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> Either
     (Map
        PackageName
        (VersionRange, Maybe (Version, BlobKey), BadDependency))
     MissingPresentDeps
forall a b. a -> Either a b
Left (Map
   PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
 -> Either
      (Map
         PackageName
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
      MissingPresentDeps)
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> Either
     (Map
        PackageName
        (VersionRange, Maybe (Version, BlobKey), BadDependency))
     MissingPresentDeps
forall a b. (a -> b) -> a -> b
$ PackageName
-> (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (VersionRange
range, Maybe (Version, BlobKey)
mLatestApp, BadDependency
err)
  PackageName
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either ConstructPlanException AddDepRes)
getCachedDepOrAddDep PackageName
name 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
            (Map
               PackageName
               (VersionRange, Maybe (Version, BlobKey), BadDependency))
            MissingPresentDeps))
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (Map
           PackageName
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
        MissingPresentDeps)
forall a b.
WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  a
-> (a
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         b)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ConstructPlanException
e -> do
      WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  ()
addParent
      let bd :: BadDependency
bd = case ConstructPlanException
e of
            UnknownPackage ActualCompiler
_ 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
      mLatestApplicable <- PackageName -> VersionRange -> M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev PackageName
name VersionRange
range
      pure $ failure mLatestApplicable bd
    Right AddDepRes
adr
      | DepType -> Bool
isDepTypeLibrary DepValue
value.depType Bool -> Bool -> Bool
&& Bool -> Bool
not (AddDepRes -> Bool
adrHasLibrary AddDepRes
adr) ->
          Either
  (Map
     PackageName
     (VersionRange, Maybe (Version, BlobKey), BadDependency))
  MissingPresentDeps
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (Map
           PackageName
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
        MissingPresentDeps)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (Map
      PackageName
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
   MissingPresentDeps
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Either
         (Map
            PackageName
            (VersionRange, Maybe (Version, BlobKey), BadDependency))
         MissingPresentDeps))
-> Either
     (Map
        PackageName
        (VersionRange, Maybe (Version, BlobKey), BadDependency))
     MissingPresentDeps
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Either
        (Map
           PackageName
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
        MissingPresentDeps)
forall a b. (a -> b) -> a -> b
$ Maybe (Version, BlobKey)
-> BadDependency
-> Either
     (Map
        PackageName
        (VersionRange, Maybe (Version, BlobKey), BadDependency))
     MissingPresentDeps
failure 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
      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
      if inRange
        then pure $ Right $ processAdr adr
        else do
          mLatestApplicable <- getLatestApplicableVersionAndRev name range
          pure $ failure mLatestApplicable (DependencyMismatch $ adrVersion 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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  vsAndRevs <- runRIO ctx $
    getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name
  pure $ do
    lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs
    revs <- Map.lookup lappVer vsAndRevs
    (cabalHash, _) <- Map.maxView revs
    Just (lappVer, 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
    config <- Getting Config Ctx Config
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO 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
    allowNewerCLI <- view $ envConfigL . to (.buildOptsCLI) . to (.allowNewer)
    let allowNewerConfig = Config
config.allowNewer
        allowNewer = Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst Bool
False (First Bool -> Bool) -> First Bool -> Bool
forall a b. (a -> b) -> a -> b
$ First Bool
allowNewerCLI First Bool -> First Bool -> First Bool
forall a. Semigroup a => a -> a -> a
<> First Bool
allowNewerConfig
        allowNewerDeps = Config
config.allowNewerDeps
    if allowNewer
      then case allowNewerDeps of
        Maybe [PackageName]
Nothing -> do
          Bool
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
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))
     ()
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
        when (isJust allowNewerDeps) $
          warn_ False $
            fillSep
              [ "although"
              , style Shell "allow-newer-deps"
              , flow "are specified,"
              , style Shell "allow-newer"
              , "is"
              , style Shell "false"
              ]
        -- We ignore dependency information for packages in a snapshot

        pkgInSnapshot <- inSnapshot pkgName version
        adrInSnapshot <- inSnapshot name (adrVersion adr)
        if pkgInSnapshot && adrInSnapshot
          then do
            warn_ True
              ( flow "trusting snapshot over Cabal file dependency \
                     \information"
              )
            pure True
          else pure False
 where
  PackageIdentifier PackageName
pkgName Version
version = PackageIdentifier
pkgId
  warn_ :: Bool
-> StyleDoc
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     ()
warn_ Bool
isIgnoring StyleDoc
reason = 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 = (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
  -> MissingPresentDeps
processAdr :: AddDepRes -> MissingPresentDeps
processAdr AddDepRes
adr = case AddDepRes
adr of
  ADRToInstall Task
task ->
    MissingPresentDeps
      { missingPackages :: Set PackageIdentifier
missingPackages = 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
      , presentPackages :: Map PackageIdentifier GhcPkgId
presentPackages = Map PackageIdentifier GhcPkgId
forall a. Monoid a => a
mempty
      , isMutable :: IsMutable
isMutable = Task -> IsMutable
taskTargetIsMutable Task
task
      }
  ADRFound InstallLocation
loc Installed
installed ->
    MissingPresentDeps
      { missingPackages :: Set PackageIdentifier
missingPackages = Set PackageIdentifier
forall a. Monoid a => a
mempty
      , presentPackages :: Map PackageIdentifier GhcPkgId
presentPackages = Map PackageIdentifier GhcPkgId
presentPackagesV
      , isMutable :: IsMutable
isMutable = InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc
      }
   where
    presentPackagesV :: Map PackageIdentifier GhcPkgId
presentPackagesV = case Installed
installed of
      Library PackageIdentifier
ident InstalledLibraryInfo
installedInfo -> PackageIdentifier
-> InstalledLibraryInfo -> Map PackageIdentifier GhcPkgId
installedMapGhcPkgId PackageIdentifier
ident InstalledLibraryInfo
installedInfo
      Installed
_ -> Map PackageIdentifier GhcPkgId
forall k a. Map k a
Map.empty

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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  moldOpts <- runRIO ctx $ tryGetFlagCache installed
  let packageConfigureOpt = Package -> PackageConfigureOpts
packageConfigureOptsFromPackage Package
package
      configureOpts = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> PackageConfigureOpts
-> ConfigureOpts
configureOptsFromBase
        (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

        PackageConfigureOpts
packageConfigureOpt
      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
        { ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts
        , deps :: 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
components :: Set ByteString
components
        , Bool
buildHaddocks :: Bool
buildHaddocks :: Bool
buildHaddocks
        , pkgSrc :: CachePkgSrc
pkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
        , pathEnvVar :: Text
pathEnvVar = Ctx
ctx.pathEnvVar
        }
      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
  mreason <-
    case 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 ->
            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 WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe (Set [Char]))
-> (Maybe (Set [Char]) -> Maybe Text)
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
              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 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

-- | If the new Cabal configuration cache is the same as the old, yields

-- 'Nothing'. Otherwise yields 'Just' a textual explanation of how they differ.

describeConfigDiff ::
     Config
  -> ConfigCache
     -- ^ The old Cabal configuration cache.

  -> ConfigCache
     -- ^ The new Cabal configuration cache.

  -> 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]]
renderConfigureOpts
           (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.

  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 {m :: * -> *} {s}.
(MonadReader s m, HasConfig s, MonadIO m) =>
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)))
     ()
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
warn Text
toolName
  tell mempty { wWarnings = (map toolWarningText warnings ++) }
 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 <- 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
    menv <- liftIO $ config.processContextSettings settings
    eFound <- runRIO menv $ findExecutable $ T.unpack toolName
    skipIf $ isRight eFound
  -- From Cabal 1.12, build-tools can specify another executable in the same

  -- package.

  notPackageExe :: Text
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
notPackageExe Text
toolName =
    WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe ())
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   (Maybe ())
 -> MaybeT
      (WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx)))
      ())
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ())
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ()
forall a b. (a -> b) -> a -> b
$ Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ())
forall {f :: * -> *}. Applicative f => Bool -> f (Maybe ())
skipIf (Bool
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe ()))
-> Bool
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ())
forall a b. (a -> b) -> a -> b
$
      StackUnqualCompName -> CompCollection StackExecutable -> Bool
forall component.
StackUnqualCompName -> CompCollection component -> Bool
collectionMember (Text -> StackUnqualCompName
unqualCompFromText Text
toolName) Package
p.executables
  warn :: Text
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
warn Text
name = WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  (Maybe ToolWarning)
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (WriterT
   W
   (StateT
      (Map PackageName (Either ConstructPlanException AddDepRes))
      (RIO Ctx))
   (Maybe ToolWarning)
 -> MaybeT
      (WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx)))
      ToolWarning)
-> (ToolWarning
    -> WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx))
         (Maybe ToolWarning))
-> ToolWarning
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     ToolWarning
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ToolWarning
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ToolWarning)
forall a.
a
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ToolWarning
 -> WriterT
      W
      (StateT
         (Map PackageName (Either ConstructPlanException AddDepRes))
         (RIO Ctx))
      (Maybe ToolWarning))
-> (ToolWarning -> Maybe ToolWarning)
-> ToolWarning
-> WriterT
     W
     (StateT
        (Map PackageName (Either ConstructPlanException AddDepRes))
        (RIO Ctx))
     (Maybe ToolWarning)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToolWarning -> Maybe ToolWarning
forall a. a -> Maybe a
Just (ToolWarning
 -> MaybeT
      (WriterT
         W
         (StateT
            (Map PackageName (Either ConstructPlanException AddDepRes))
            (RIO Ctx)))
      ToolWarning)
-> ToolWarning
-> MaybeT
     (WriterT
        W
        (StateT
           (Map PackageName (Either ConstructPlanException AddDepRes))
           (RIO Ctx)))
     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 <- WriterT
  W
  (StateT
     (Map PackageName (Either ConstructPlanException AddDepRes))
     (RIO Ctx))
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
  pure $ fromMaybe False $
    Map.lookup name ctx.combinedMap >>= \case
      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
  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)
  when debugPlan $ logDebugS s 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))

toCachePkgSrc :: PackageSource -> CachePkgSrc
toCachePkgSrc :: PackageSource -> CachePkgSrc
toCachePkgSrc (PSFilePath LocalPackage
lp) =
  [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))
toCachePkgSrc PSRemote{} = CachePkgSrc
CacheSrcUpstream