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

-- | Construct a @Plan@ for how to build
module Stack.Build.ConstructPlan
  ( constructPlan
  ) where

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

data PackageInfo
  = PIOnlyInstalled InstallLocation Installed
    -- ^ This indicates that the package is already installed, and that we
    -- shouldn't build it from source. This is only the case for global
    -- packages.
  | PIOnlySource PackageSource
    -- ^ This indicates that the package isn't installed, and we know where to
    -- find its source.
  | PIBoth PackageSource Installed
    -- ^ This indicates that the package is installed and we know where to find
    -- its source. We may want to reinstall from source.
  deriving Show

combineSourceInstalled :: PackageSource
                       -> (InstallLocation, Installed)
                       -> PackageInfo
combineSourceInstalled ps (location, installed) =
  assert (psVersion ps == installedVersion installed) $
    case location of
      -- Always trust something in the snapshot
      Snap -> PIOnlyInstalled location installed
      Local -> PIBoth ps installed

type CombinedMap = Map PackageName PackageInfo

combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap = Map.merge
  (Map.mapMissing (\_ s -> PIOnlySource s))
  (Map.mapMissing (\_ i -> uncurry PIOnlyInstalled i))
  (Map.zipWithMatched (\_ s i -> combineSourceInstalled s i))

data AddDepRes
  = ADRToInstall Task
  | ADRFound InstallLocation Installed
  deriving Show

data W = W
  { wFinals :: !(Map PackageName (Either ConstructPlanException Task))
  , wInstall :: !(Map Text InstallLocation)
    -- ^ executable to be installed, and location where the binary is placed
  , wDirty :: !(Map PackageName Text)
    -- ^ why a local package is considered dirty
  , wWarnings :: !([StyleDoc] -> [StyleDoc])
    -- ^ Warnings
  , wParents :: !ParentMap
    -- ^ Which packages a given package depends on, along with the package's
    -- version
  }
  deriving Generic

instance Semigroup W where
  (<>) = mappenddefault

instance Monoid W where
  mempty = memptydefault
  mappend = (<>)

type M = RWST -- TODO replace with more efficient WS stack on top of (RIO Ctx).
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  -- ^ Library map
  IO

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

instance HasPlatform Ctx where
  platformL = configL.platformL
  {-# INLINE platformL #-}
  platformVariantL = configL.platformVariantL
  {-# INLINE platformVariantL #-}

instance HasGHCVariant Ctx where
  ghcVariantL = configL.ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasLogFunc Ctx where
  logFuncL = configL.logFuncL

instance HasRunner Ctx where
  runnerL = configL.runnerL

instance HasStylesUpdate Ctx where
  stylesUpdateL = runnerL.stylesUpdateL

instance HasTerm Ctx where
  useColorL = runnerL.useColorL
  termWidthL = runnerL.termWidthL

instance HasConfig Ctx where
  configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y })
  {-# INLINE configL #-}

instance HasPantryConfig Ctx where
  pantryConfigL = configL.pantryConfigL

instance HasProcessContext Ctx where
  processContextL = configL.processContextL

instance HasBuildConfig Ctx where
  buildConfigL = envConfigL.lens
    envConfigBuildConfig
    (\x y -> x { envConfigBuildConfig = y })

instance HasSourceMap Ctx where
  sourceMapL = envConfigL.sourceMapL

instance HasCompiler Ctx where
  compilerPathsL = envConfigL.compilerPathsL

instance HasEnvConfig Ctx where
  envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y })

-- | Computes a build plan. This means figuring out which build 'Task's to take,
-- and the interdependencies among the build 'Task's. In particular:
--
-- 1) It determines which packages need to be built, based on the transitive
-- deps of the current targets. For local packages, this is indicated by the
-- 'lpWanted' boolean. For extra packages to build, this comes from the
-- @extraToBuild0@ argument of type @Set PackageName@. These are usually
-- packages that have been specified on the command line.
--
-- 2) It will only rebuild an upstream package if it isn't present in the
-- 'InstalledMap', or if some of its dependencies have changed.
--
-- 3) It will only rebuild a local package if its files are dirty or some of its
-- dependencies have changed.
constructPlan ::
     forall env. HasEnvConfig env
  => BaseConfigOpts
  -> [DumpPackage] -- ^ locally registered
  -> (  PackageLocationImmutable
     -> Map FlagName Bool
     -> [Text]
     -> [Text]
     -> RIO EnvConfig Package
     )
     -- ^ load upstream package
  -> SourceMap
  -> InstalledMap
  -> Bool
  -> RIO env Plan
constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do
  logDebug "Constructing the build plan"

  when hasBaseInDeps $
    prettyWarn $
         fillSep
           [ flow "You are trying to upgrade or downgrade the"
           , style Current "base"
           , flow "package, which is almost certainly not what you really \
                  \want. Please, consider using another GHC version if you \
                  \need a certain version of"
           , style Current "base" <> ","
           , flow "or removing"
           , style Current "base"
           , flow "as an"
           , style Shell "extra-deps" <> "."
           , flow "For further information, see"
           , style Url "https://github.com/commercialhaskell/stack/issues/3940" <> "."
           ]
      <> line

  econfig <- view envConfigL
  globalCabalVersion <- view $ compilerPathsL.to cpCabalVersion
  sources <- getSources globalCabalVersion
  mcur <- view $ buildConfigL.to bcCurator

  let onTarget = void . getCachedDepOrAddDep
  let inner = mapM_ onTarget $ Map.keys (smtTargets $ smTargets sourceMap)
  pathEnvVar' <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
  let ctx = mkCtx econfig globalCabalVersion sources mcur pathEnvVar'
  ((), m, W efinals installExes dirtyReason warnings parents) <-
    liftIO $ runRWST inner ctx Map.empty
  mapM_ prettyWarn (warnings [])
  let toEither (_, Left e)  = Left e
      toEither (k, Right v) = Right (k, v)
      (errlibs, adrs) = partitionEithers $ map toEither $ Map.toList m
      (errfinals, finals) = partitionEithers $ map toEither $ Map.toList efinals
      errs = errlibs ++ errfinals
  if null errs
    then do
      let toTask (_, ADRFound _ _) = Nothing
          toTask (name, ADRToInstall task) = Just (name, task)
          tasks = Map.fromList $ mapMaybe toTask adrs
          takeSubset =
            case boptsCLIBuildSubset $ bcoBuildOptsCLI baseConfigOpts0 of
              BSAll -> pure
              BSOnlySnapshot -> pure . stripLocals
              BSOnlyDependencies ->
                pure . stripNonDeps (Map.keysSet $ smDeps sourceMap)
              BSOnlyLocals -> errorOnSnapshot
      takeSubset Plan
        { planTasks = tasks
        , planFinals = Map.fromList finals
        , planUnregisterLocal =
            mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps
        , planInstallExes =
            if boptsInstallExes (bcoBuildOpts baseConfigOpts0) ||
               boptsInstallCompilerTool (bcoBuildOpts baseConfigOpts0)
                then installExes
                else Map.empty
        }
    else do
      stackYaml <- view stackYamlL
      stackRoot <- view stackRootL
      isImplicitGlobal <- view $ configL.to (isPCGlobalProject . configProject)
      prettyThrowM $ ConstructPlanFailed
        errs stackYaml stackRoot isImplicitGlobal parents (wanted ctx) prunedGlobalDeps
 where
  hasBaseInDeps = Map.member (mkPackageName "base") (smDeps sourceMap)

  mkCtx econfig globalCabalVersion sources mcur pathEnvVar' = Ctx
    { baseConfigOpts = baseConfigOpts0
    , loadPackage = \w x y z -> runRIO econfig $
        applyForceCustomBuild globalCabalVersion <$> loadPackage0 w x y z
    , combinedMap = combineMap sources installedMap
    , ctxEnvConfig = econfig
    , callStack = []
    , wanted = Map.keysSet (smtTargets $ smTargets sourceMap)
    , localNames = Map.keysSet (smProject sourceMap)
    , mcurator = mcur
    , pathEnvVar = pathEnvVar'
    }

  prunedGlobalDeps = flip Map.mapMaybe (smGlobal sourceMap) $
    \case
      ReplacedGlobalPackage deps ->
        let pruned = filter (not . inSourceMap) deps
        in  if null pruned then Nothing else Just pruned
      GlobalPackage _ -> Nothing

  inSourceMap pname = pname `Map.member` smDeps sourceMap ||
                      pname `Map.member` smProject sourceMap

  getSources :: Version -> RIO env (Map PackageName PackageSource)
  getSources globalCabalVersion = do
    let loadLocalPackage' pp = do
          lp <- loadLocalPackage pp
          let lpPackage' =
                applyForceCustomBuild globalCabalVersion $ lpPackage lp
          pure lp { lpPackage = lpPackage' }
    pPackages <- for (smProject sourceMap) $ \pp -> do
      lp <- loadLocalPackage' pp
      pure $ PSFilePath lp
    bopts <- view $ configL.to configBuild
    deps <- for (smDeps sourceMap) $ \dp ->
      case dpLocation dp of
        PLImmutable loc ->
          pure $
            PSRemote loc (getPLIVersion loc) (dpFromSnapshot dp) (dpCommon dp)
        PLMutable dir -> do
          pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)
          lp <- loadLocalPackage' pp
          pure $ PSFilePath lp
    pure $ pPackages <> deps

-- | Throw an exception if there are any snapshot packages in the plan.
errorOnSnapshot :: Plan -> RIO env Plan
errorOnSnapshot plan@(Plan tasks _finals _unregister installExes) = do
  let snapTasks = Map.keys $ Map.filter (\t -> taskLocation t == Snap) tasks
  let snapExes = Map.keys $ Map.filter (== Snap) installExes
  unless (null snapTasks && null snapExes) $ throwIO $
    NotOnlyLocal snapTasks snapExes
  pure plan

data NotOnlyLocal
  = NotOnlyLocal [PackageName] [Text]
  deriving (Show, Typeable)

instance Exception NotOnlyLocal where
  displayException (NotOnlyLocal packages exes) = concat
    [ "Error: [S-1727]\n"
    , "Specified only-locals, but I need to build snapshot contents:\n"
    , if null packages then "" else concat
        [ "Packages: "
        , L.intercalate ", " (map packageNameString packages)
        , "\n"
        ]
    , if null exes then "" else concat
        [ "Executables: "
        , L.intercalate ", " (map T.unpack exes)
        , "\n"
        ]
    ]

-- | State to be maintained during the calculation of local packages
-- to unregister.
data UnregisterState = UnregisterState
  { usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text))
  , usKeep :: ![DumpPackage]
  , usAnyAdded :: !Bool
  }

-- | Determine which packages to unregister based on the given tasks and
-- already registered local packages.
mkUnregisterLocal ::
     Map PackageName Task
     -- ^ Tasks
  -> Map PackageName Text
     -- ^ Reasons why packages are dirty and must be rebuilt
  -> [DumpPackage]
     -- ^ Local package database dump
  -> Bool
     -- ^ If true, we're doing a special initialBuildSteps build - don't
     -- unregister target packages.
  -> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal tasks dirtyReason localDumpPkgs 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.
  loop Map.empty 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 toUnregister 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.
    | usAnyAdded us = loop (usToUnregister us) (usKeep us)
    -- Nothing added, so we've already caught them all. Return the Map we've
    -- already calculated.
    | otherwise = usToUnregister us
   where
    -- Run the unregister checking function on all packages we currently think
    -- we'll be keeping.
    us = execState (mapM_ go keep) initialUnregisterState
    initialUnregisterState = UnregisterState
      { usToUnregister = toUnregister
      , usKeep = []
      , usAnyAdded = False
      }

  go :: DumpPackage -> State UnregisterState ()
  go dp = do
    us <- get
    case maybeUnregisterReason (usToUnregister us) ident mParentLibId deps of
      -- Not unregistering, add it to the keep list.
      Nothing -> put us { usKeep = dp : usKeep us }
      -- Unregistering, add it to the unregister Map; and indicate that a
      -- package was in fact added to the unregister Map, so we loop again.
      Just reason -> put us
        { usToUnregister = Map.insert gid (ident, reason) (usToUnregister us)
        , usAnyAdded = True
        }
   where
    gid = dpGhcPkgId dp
    ident = dpPackageIdent dp
    mParentLibId = dpParentLibIdent dp
    deps = dpDepends dp

  maybeUnregisterReason ::
       Map GhcPkgId (PackageIdentifier, Text)
       -- ^ Current local packages to unregister.
    -> PackageIdentifier
       -- ^ Package identifier.
    -> Maybe PackageIdentifier
       -- ^ If package for sub library, package identifier of the parent.
    -> [GhcPkgId]
       -- ^ Dependencies of the package.
    -> Maybe Text
       -- ^ If to be unregistered, the reason for doing so.
  maybeUnregisterReason toUnregister ident mParentLibId 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 <- Map.lookup relevantPkgName tasks =
        if    initialBuildSteps
           && taskIsTarget task
           && taskProvides task == relevantPkgId
          then Nothing
          else Just $ fromMaybe "" $ Map.lookup relevantPkgName dirtyReason
    -- Check if a dependency is going to be unregistered
    | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps =
        Just $ "Dependency being unregistered: "
          <> T.pack (packageIdentifierString dep)
    -- None of the above, keep it!
    | otherwise = 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 = fromMaybe ident 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 = maybe (pkgName ident) pkgName mParentLibId

-- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for running its
-- tests and benchmarks.
--
-- If @isAllInOne@ is 'True', then this means that the build step will also
-- build the tests. Otherwise, this indicates that there's a cyclic dependency
-- and an additional build step needs to be done.
--
-- This will also add all the deps needed to build the tests / benchmarks. If
-- @isAllInOne@ is 'True' (the common case), then all of these should have
-- already been taken care of as part of the build step.
addFinal :: LocalPackage -> Package -> Bool -> Bool -> M ()
addFinal lp package isAllInOne buildHaddocks = do
  depsRes <- addPackageDeps package
  res <- case depsRes of
    Left e -> pure $ Left e
    Right (missing, present, _minLoc) -> do
      ctx <- ask
      pure $ Right Task
        { taskProvides = PackageIdentifier
            (packageName package)
            (packageVersion package)
        , taskConfigOpts = TaskConfigOpts missing $ \missing' ->
            let allDeps = Map.union present missing'
            in  configureOpts
                  (view envConfigL ctx)
                  (baseConfigOpts ctx)
                  allDeps
                  True -- local
                  Mutable
                  package
        , taskBuildHaddock = buildHaddocks
        , taskPresent = present
        , taskType = TTLocalMutable lp
        , taskAllInOne = isAllInOne
        , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent (lpCabalFile lp)))
        , taskAnyMissing = not $ Set.null missing
        , taskBuildTypeConfig = packageBuildTypeConfig package
        }
  tell mempty { wFinals = Map.singleton (packageName package) 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 name = do
  libMap <- get
  case Map.lookup name libMap of
    Just res -> do
      logDebugPlanS "getCachedDepOrAddDep" $
           "Using cached result for "
        <> fromString (packageNameString name)
        <> ": "
        <> fromString (show res)
      pure res
    Nothing -> checkCallStackAndAddDep 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 name = do
  ctx <- ask
  res <- if name `elem` callStack ctx
    then do
      logDebugPlanS "checkCallStackAndAddDep" $
           "Detected cycle "
        <> fromString (packageNameString name)
        <> ": "
        <> fromString (show $ map packageNameString (callStack ctx))
      pure $ Left $ DependencyCycleDetected $ name : callStack ctx
    else case Map.lookup name $ combinedMap ctx of
      -- TODO look up in the package index and see if there's a
      -- recommendation available
      Nothing -> do
        logDebugPlanS "checkCallStackAndAddDep" $
             "No package info for "
          <> fromString (packageNameString name)
          <> "."
        pure $ Left $ UnknownPackage name
      Just packageInfo ->
        -- Add the current package name to the head of the call stack.
        local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $
          addDep name 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 name packageInfo = do
  logDebugPlanS "addDep" $
       "Package info for "
    <> fromString (packageNameString name)
    <> ": "
    <> fromString (show packageInfo)
  case packageInfo of
    PIOnlyInstalled loc installed -> do
      -- FIXME Slightly hacky, no flags since they likely won't affect
      -- executable names. This code does not feel right.
      let version = installedVersion installed
          askPkgLoc = liftRIO $ do
            mrev <- getLatestHackageRevision YesRequireHackageIndex name version
            case mrev of
              Nothing -> do
                -- This could happen for GHC boot libraries missing from
                -- Hackage.
                cs <- asks (L.tail . callStack)
                prettyWarnL
                  $ flow "No latest package revision found for"
                  : style Current (fromString $ packageNameString name) <> ","
                  : flow "dependency callstack:"
                  : mkNarrativeList Nothing False
                      (map (fromString . packageNameString) cs :: [StyleDoc])
                pure Nothing
              Just (_rev, cfKey, treeKey) ->
                pure $ Just $
                  PLIHackage (PackageIdentifier name version) cfKey treeKey
      tellExecutablesUpstream name askPkgLoc loc Map.empty
      pure $ Right $ ADRFound loc installed
    PIOnlySource ps -> do
      tellExecutables name ps
      installPackage name ps Nothing
    PIBoth ps installed -> do
      tellExecutables name ps
      installPackage name ps (Just installed)

-- FIXME what's the purpose of this? Add a Haddock!
tellExecutables :: PackageName -> PackageSource -> M ()
tellExecutables _name (PSFilePath lp)
  | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp
  | otherwise = pure ()
-- Ignores ghcOptions because they don't matter for enumerating executables.
tellExecutables name (PSRemote pkgloc _version _fromSnapshot cp) =
  tellExecutablesUpstream name (pure $ Just pkgloc) Snap (cpFlags cp)

tellExecutablesUpstream ::
     PackageName
  -> M (Maybe PackageLocationImmutable)
  -> InstallLocation
  -> Map FlagName Bool
  -> M ()
tellExecutablesUpstream name retrievePkgLoc loc flags = do
  ctx <- ask
  when (name `Set.member` wanted ctx) $ do
    mPkgLoc <- retrievePkgLoc
    forM_ mPkgLoc $ \pkgLoc -> do
      p <- loadPackage ctx pkgLoc flags [] []
      tellExecutablesPackage loc p

tellExecutablesPackage :: InstallLocation -> Package -> M ()
tellExecutablesPackage loc p = do
  cm <- asks combinedMap
  -- Determine which components are enabled so we know which ones to copy
  let myComps =
        case Map.lookup (packageName p) cm of
          Nothing -> assert False Set.empty
          Just (PIOnlyInstalled _ _) -> Set.empty
          Just (PIOnlySource ps) -> goSource ps
          Just (PIBoth ps _) -> goSource ps

      goSource (PSFilePath lp)
        | lpWanted lp = exeComponents (lpComponents lp)
        | otherwise = Set.empty
      goSource PSRemote{} = Set.empty

  tell mempty
    { wInstall = Map.fromList $
        map (, loc) $ Set.toList $ filterComps myComps $ packageExes p
    }
 where
  filterComps myComps x
    | Set.null myComps = x
    | otherwise = Set.intersection x myComps

-- | Given a 'PackageSource' and perhaps an 'Installed' value, adds build
-- 'Task's for the package and its dependencies.
installPackage :: PackageName
               -> PackageSource
               -> Maybe Installed
               -> M (Either ConstructPlanException AddDepRes)
installPackage name ps minstalled = do
  ctx <- ask
  case ps of
    PSRemote pkgLoc _version _fromSnapshot cp -> do
      logDebugPlanS "installPackage" $
           "Doing all-in-one build for upstream package "
        <> fromString (packageNameString name)
        <> "."
      package <- loadPackage
        ctx pkgLoc (cpFlags cp) (cpGhcOptions cp) (cpCabalConfigOpts cp)
      resolveDepsAndInstall True (cpHaddocks cp) ps package minstalled
    PSFilePath lp -> do
      case lpTestBench lp of
        Nothing -> do
          logDebugPlanS "installPackage" $
               "No test or bench component for "
            <> fromString (packageNameString name)
            <> " so doing an all-in-one build."
          resolveDepsAndInstall
            True (lpBuildHaddocks lp) ps (lpPackage lp) minstalled
        Just 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 <- get
          res <- pass $ do
            res <- addPackageDeps tb
            let writerFunc w = case res of
                  Left _ -> mempty
                  _ -> w
            pure (res, writerFunc)
          case res of
            Right deps -> do
              logDebugPlanS "installPackage" $
                   "For "
                <> fromString (packageNameString name)
                <> ", 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 <- expectedTestOrBenchFailures <$> asks mcurator
              let isAllInOne = not splitRequired
              adr <- installPackageGivenDeps
                isAllInOne (lpBuildHaddocks lp) ps tb minstalled deps
              let finalAllInOne = case adr of
                    ADRToInstall _ | splitRequired -> False
                    _ -> True
              -- 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 _ -> do
              -- Reset the state to how it was before attempting to find an
              -- all-in-one build plan.
              logDebugPlanS "installPackage" $
                   "Before trying cyclic plan, resetting lib result map to: "
                <> fromString (show libMap)
              put libMap
              -- Otherwise, fall back on building the tests / benchmarks in a
              -- separate step.
              res' <- resolveDepsAndInstall
                False (lpBuildHaddocks lp) ps (lpPackage lp) 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 maybeCurator = fromMaybe False $ do
    curator <- maybeCurator
    pure $ Set.member name (curatorExpectTestFailure curator) ||
           Set.member name (curatorExpectBenchmarkFailure curator)

resolveDepsAndInstall :: Bool
                      -> Bool
                      -> PackageSource
                      -> Package
                      -> Maybe Installed
                      -> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall isAllInOne buildHaddocks ps package minstalled = do
  res <- addPackageDeps package
  case res of
    Left err -> pure $ Left err
    Right deps ->
      Right <$>
        installPackageGivenDeps
          isAllInOne buildHaddocks ps package minstalled deps

-- | Checks if we need to install the given 'Package', given the results
-- of 'addPackageDeps'. If dependencies are missing, the package is dirty, or
-- it's not installed, then it needs to be installed.
installPackageGivenDeps :: Bool
                        -> Bool
                        -> PackageSource
                        -> Package
                        -> Maybe Installed
                        -> ( Set PackageIdentifier
                           , Map PackageIdentifier GhcPkgId
                           , IsMutable )
                        -> M AddDepRes
installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled
  (missing, present, minMutable) = do
    let name = packageName package
    ctx <- ask
    mRightVersionInstalled <- case (minstalled, Set.null missing) of
      (Just installed, True) -> do
        shouldInstall <-
          checkDirtiness ps installed package present buildHaddocks
        pure $ if shouldInstall then Nothing else Just installed
      (Just _, False) -> do
        let t = T.intercalate ", " $
                  map (T.pack . packageNameString . pkgName) (Set.toList missing)
        tell mempty
          { wDirty =
              Map.singleton name $ "missing dependencies: " <> addEllipsis t
          }
        pure Nothing
      (Nothing, _) -> pure Nothing
    let loc = psLocation ps
        mutable = installLocationIsMutable loc <> minMutable
    pure $ case mRightVersionInstalled of
      Just installed -> ADRFound loc installed
      Nothing -> ADRToInstall Task
        { taskProvides = PackageIdentifier
            (packageName package)
            (packageVersion package)
        , taskConfigOpts = TaskConfigOpts missing $ \missing' ->
            let allDeps = Map.union present missing'
            in  configureOpts
                  (view envConfigL ctx)
                  (baseConfigOpts ctx)
                  allDeps
                  (psLocal ps)
                  mutable
                  package
        , taskBuildHaddock = buildHaddocks
        , taskPresent = present
        , taskType =
            case ps of
              PSFilePath lp ->
                TTLocalMutable lp
              PSRemote pkgLoc _version _fromSnapshot _cp ->
                TTRemotePackage mutable package pkgLoc
        , taskAllInOne = isAllInOne
        , taskCachePkgSrc = toCachePkgSrc ps
        , taskAnyMissing = not $ Set.null missing
        , taskBuildTypeConfig = packageBuildTypeConfig package
        }

-- | Is the build type of the package Configure
packageBuildTypeConfig :: Package -> Bool
packageBuildTypeConfig pkg = packageBuildType pkg == 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 name val = modify $ \mp ->
  case (Map.lookup name mp, val) of
    (Just (Left DependencyCycleDetected{}), Left _) -> mp
    _ -> Map.insert name val mp

addEllipsis :: Text -> Text
addEllipsis t
  | T.length t < 100 = t
  | otherwise = T.take 97 t <> "..."

-- | Given a package, recurses into all of its dependencies. The results
-- indicate which packages are missing, meaning that their 'GhcPkgId's will be
-- figured out during the build, after they've been built. The 2nd part of the
-- tuple result indicates the packages that are already installed which will be
-- used.
--
-- The 3rd part of the tuple is an 'InstallLocation'. If it is 'Local', then the
-- parent package must be installed locally. Otherwise, if it is 'Snap', then it
-- can either be installed locally or in the snapshot.
addPackageDeps ::
     Package
  -> M ( Either
           ConstructPlanException
           ( Set PackageIdentifier
           , Map PackageIdentifier GhcPkgId
           , IsMutable
           )
       )
addPackageDeps package = do
  ctx <- ask
  checkAndWarnForUnknownTools package
  let deps' = packageDeps package
  deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do
    eres <- getCachedDepOrAddDep depname
    let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
        getLatestApplicableVersionAndRev = do
          vsAndRevs <-
            runRIO ctx $
              getHackagePackageVersions
                YesRequireHackageIndex UsePreferredVersions depname
          pure $ do
            lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs
            revs <- Map.lookup lappVer vsAndRevs
            (cabalHash, _) <- Map.maxView revs
            Just (lappVer, cabalHash)
    case eres of
      Left e -> do
        addParent depname range Nothing
        let bd = case e of
              UnknownPackage name -> assert (name == depname) NotInBuildPlan
              DependencyCycleDetected names -> BDDependencyCycleDetected 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 _ _  ->
                Couldn'tResolveItsDependencies (packageVersion package)
        mlatestApplicable <- getLatestApplicableVersionAndRev
        pure $ Left (depname, (range, mlatestApplicable, bd))
      Right adr | depType == AsLibrary && not (adrHasLibrary adr) ->
        pure $ Left (depname, (range, Nothing, HasNoLibrary))
      Right adr -> do
        addParent depname range Nothing
        inRange <- if adrVersion adr `withinRange` range
          then pure True
          else do
            let warn_ isIgnoring reason = tell mempty { wWarnings = (msg:) }
                 where
                  msg =
                       fillSep
                         [ if isIgnoring then "Ignoring" else flow "Not ignoring"
                         , style Current (fromString . packageNameString $ packageName package) <> "'s"
                         , flow "bounds on"
                         , style Current (fromString $ packageNameString depname)
                         , parens (fromString . T.unpack $ versionRangeText range)
                         , flow "and using"
                         , style Current (fromString . packageIdentifierString $
                             PackageIdentifier depname (adrVersion adr)) <> "."
                         ]
                    <> line
                    <> fillSep
                         [ "Reason:"
                         , reason <> "."
                         ]
            allowNewer <- view $ configL.to configAllowNewer
            allowNewerDeps <- view $ configL.to configAllowNewerDeps
            let inSnapshotCheck = do
                  -- We ignore dependency information for packages in a snapshot
                  x <- inSnapshot (packageName package) (packageVersion package)
                  y <- inSnapshot depname (adrVersion adr)
                  if x && y
                    then do
                      warn_ True
                        ( flow "trusting snapshot over Cabal file dependency \
                               \information"
                        )
                      pure True
                    else pure False
            if allowNewer
              then case allowNewerDeps of
                Nothing -> do
                  warn_ True $
                    fillSep
                      [ style Shell "allow-newer"
                      , "enabled"
                      ]
                  pure True
                Just boundsIgnoredDeps -> do
                  let pkgName = packageName package
                      pkgName' = fromString $ packageNameString pkgName
                      isBoundsIgnoreDep = pkgName `elem` boundsIgnoredDeps
                      reason = if isBoundsIgnoreDep
                        then fillSep
                          [ style Current pkgName'
                          , flow "is an"
                          , style Shell "allow-newer-dep"
                          , flow "and"
                          , style Shell "allow-newer"
                          , "enabled"
                          ]
                        else fillSep
                          [ style Current pkgName'
                          , flow "is not an"
                          , style Shell "allow-newer-dep"
                          , flow "although"
                          , style Shell "allow-newer"
                          , "enabled"
                          ]
                  warn_ isBoundsIgnoreDep reason
                  pure 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"
                      ]
                inSnapshotCheck
        if inRange
          then case adr of
            ADRToInstall task -> pure $ Right
              ( Set.singleton $ taskProvides task
              , Map.empty, taskTargetIsMutable task
              )
            ADRFound loc (Executable _) -> pure $ Right
              ( Set.empty, Map.empty
              , installLocationIsMutable loc
              )
            ADRFound loc (Library ident gid _) -> pure $ Right
              ( Set.empty, Map.singleton ident gid
              , installLocationIsMutable loc
              )
          else do
            mlatestApplicable <- getLatestApplicableVersionAndRev
            pure $ Left
              ( depname
              , ( range
                , mlatestApplicable
                , DependencyMismatch $ adrVersion adr
                )
              )
  case partitionEithers deps of
    -- Note that the Monoid for 'InstallLocation' means that if any
    -- is 'Local', the result is 'Local', indicating that the parent
    -- package must be installed locally. Otherwise the result is
    -- 'Snap', indicating that the parent can either be installed
    -- locally or in the snapshot.
    ([], pairs) -> pure $ Right $ mconcat pairs
    (errs, _) -> pure $ Left $ DependencyPlanFailures
      package
      (Map.fromList errs)
 where
  adrVersion (ADRToInstall task) = pkgVersion $ taskProvides task
  adrVersion (ADRFound _ installed) = installedVersion installed
  -- Update the parents map, for later use in plan construction errors
  -- - see 'getShortestDepsPath'.
  addParent depname range mversion =
    tell mempty { wParents = MonoidMap $ Map.singleton depname val }
   where
    val = (First mversion, [(packageIdentifier package, range)])

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

  taskHasLibrary :: Task -> Bool
  taskHasLibrary task =
    case taskType task of
      TTLocalMutable lp -> packageHasLibrary $ lpPackage lp
      TTRemotePackage _ p _ -> packageHasLibrary p

  -- make sure we consider internal libraries as libraries too
  packageHasLibrary :: Package -> Bool
  packageHasLibrary p =
    not (Set.null (packageInternalLibraries p)) ||
    case packageLibraries p of
      HasLibraries _ -> True
      NoLibraries -> False

checkDirtiness :: PackageSource
               -> Installed
               -> Package
               -> Map PackageIdentifier GhcPkgId
               -> Bool
               -> M Bool
checkDirtiness ps installed package present buildHaddocks = do
  ctx <- ask
  moldOpts <- runRIO ctx $ tryGetFlagCache installed
  let configOpts = configureOpts
        (view envConfigL ctx)
        (baseConfigOpts ctx)
        present
        (psLocal ps)
        (installLocationIsMutable $ psLocation ps) -- should be Local i.e. mutable always
        package
      wantConfigCache = ConfigCache
        { configCacheOpts = configOpts
        , configCacheDeps = Set.fromList $ Map.elems present
        , configCacheComponents =
            case ps of
              PSFilePath lp ->
                Set.map (encodeUtf8 . renderComponent) $ lpComponents lp
              PSRemote{} -> Set.empty
        , configCacheHaddock = buildHaddocks
        , configCachePkgSrc = toCachePkgSrc ps
        , configCachePathEnvVar = pathEnvVar ctx
        }
      config = view configL ctx
  mreason <-
    case moldOpts of
      Nothing -> pure $ Just "old configure information not found"
      Just oldOpts
        | Just reason <- describeConfigDiff config oldOpts wantConfigCache ->
            pure $ Just reason
        | True <- psForceDirty ps -> pure $ Just "--force-dirty specified"
        | otherwise -> do
            dirty <- psDirty ps
            pure $
              case dirty of
                Just files -> Just $
                     "local file changes: "
                  <> addEllipsis (T.pack $ unwords $ Set.toList files)
                Nothing -> Nothing
  case mreason of
    Nothing -> pure False
    Just reason -> do
      tell mempty { wDirty = Map.singleton (packageName package) reason }
      pure True

describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff config old new
  | configCachePkgSrc old /= configCachePkgSrc new = Just $
      "switching from " <>
      pkgSrcName (configCachePkgSrc old) <> " to " <>
      pkgSrcName (configCachePkgSrc new)
  | not (configCacheDeps new `Set.isSubsetOf` configCacheDeps old) =
      Just "dependencies changed"
  | not $ Set.null newComponents =
      Just $ "components added: " `T.append` T.intercalate ", "
          (map (decodeUtf8With lenientDecode) (Set.toList newComponents))
  | not (configCacheHaddock old) && configCacheHaddock new =
      Just "rebuilding with haddocks"
  | oldOpts /= newOpts = Just $ T.pack $ concat
      [ "flags changed from "
      , show oldOpts
      , " to "
      , show newOpts
      ]
  | otherwise = Nothing
 where
  stripGhcOptions = go
   where
    go [] = []
    go ("--ghc-option":x:xs) = go' Ghc x xs
    go ("--ghc-options":x:xs) = go' Ghc x xs
    go ((T.stripPrefix "--ghc-option=" -> Just x):xs) = go' Ghc x xs
    go ((T.stripPrefix "--ghc-options=" -> Just x):xs) = go' Ghc x xs
    go (x:xs) = x : go xs

    go' wc x xs = checkKeepers wc x $ go xs

    checkKeepers wc x xs =
      case filter isKeeper $ T.words x of
        [] -> xs
        keepers -> T.pack (compilerOptionsCabalFlag wc) : T.unwords keepers : 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 = (== "-fhpc") -- more to be added later

  userOpts = filter (not . isStackOpt)
           . (if configRebuildGhcOptions config
                then id
                else stripGhcOptions)
           . map T.pack
           . (\(ConfigureOpts x y) -> x ++ y)
           . configCacheOpts
   where
    -- options set by Stack
    isStackOpt :: Text -> Bool
    isStackOpt t = any (`T.isPrefixOf` t)
      [ "--dependency="
      , "--constraint="
      , "--package-db="
      , "--libdir="
      , "--bindir="
      , "--datadir="
      , "--libexecdir="
      , "--sysconfdir"
      , "--docdir="
      , "--htmldir="
      , "--haddockdir="
      , "--enable-tests"
      , "--enable-benchmarks"
      , "--exact-configuration"
      -- Treat these as causing dirtiness, to resolve
      -- https://github.com/commercialhaskell/stack/issues/2984
      --
      -- , "--enable-library-profiling"
      -- , "--enable-executable-profiling"
      -- , "--enable-profiling"
      ] || t == "--user"

  (oldOpts, newOpts) = removeMatching (userOpts old) (userOpts new)

  removeMatching (x:xs) (y:ys)
    | x == y = removeMatching xs ys
  removeMatching xs ys = (xs, ys)

  newComponents =
    configCacheComponents new `Set.difference` configCacheComponents old

  pkgSrcName (CacheSrcLocal fp) = T.pack fp
  pkgSrcName CacheSrcUpstream = "upstream source"

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

psDirty ::
     (MonadIO m, HasEnvConfig env, MonadReader env m)
  => PackageSource
  -> m (Maybe (Set FilePath))
psDirty (PSFilePath lp) = runMemoizedWith $ lpDirtyFiles lp
psDirty PSRemote {} = pure Nothing -- files never change in a remote package

psLocal :: PackageSource -> Bool
psLocal (PSFilePath _ ) = True
psLocal PSRemote{} = False

psLocation :: PackageSource -> InstallLocation
psLocation (PSFilePath _) = Local
psLocation PSRemote{} = Snap

-- | Get all of the dependencies for a given package, including build
-- tool dependencies.
checkAndWarnForUnknownTools :: Package -> M ()
checkAndWarnForUnknownTools p = do
  let unknownTools = Set.toList $ packageUnknownTools p
  -- Check whether the tool is on the PATH or a package executable before
  -- warning about it.
  warnings <-
    fmap catMaybes $ forM unknownTools $ \name@(ExeName toolName) ->
      runMaybeT $ notOnPath toolName *> notPackageExe toolName *> warn name
  tell mempty { wWarnings = (map toolWarningText warnings ++) }
  pure ()
 where
  -- From Cabal 2.0, build-tools can specify a pre-built executable that should
  -- already be on the PATH.
  notOnPath toolName = MaybeT $ do
    let settings = minimalEnvSettings { esIncludeLocals = True }
    config <- view configL
    menv <- liftIO $ configProcessContextSettings config 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 toolName = MaybeT $ skipIf $ toolName `Set.member` packageExes p
  warn name = MaybeT . pure . Just $ ToolWarning name (packageName p)
  skipIf p' = pure $ if p' then Nothing else Just ()

-- | Warn about tools in the snapshot definition. States the tool name
-- expected and the package name using it.
data ToolWarning
  = ToolWarning ExeName PackageName
  deriving Show

toolWarningText :: ToolWarning -> StyleDoc
toolWarningText (ToolWarning (ExeName toolName) pkgName') = fillSep
  [ flow "No packages found in snapshot which provide a"
  , style PkgComponent (fromString $ show toolName)
  , flow "executable, which is a build-tool dependency of"
  , style Current (fromString $ packageNameString pkgName')
  ]

-- | Strip out anything from the @Plan@ intended for the local database
stripLocals :: Plan -> Plan
stripLocals plan = plan
  { planTasks = Map.filter checkTask $ planTasks plan
  , planFinals = Map.empty
  , planUnregisterLocal = Map.empty
  , planInstallExes = Map.filter (/= Local) $ planInstallExes plan
  }
 where
  checkTask task = taskLocation task == Snap

stripNonDeps :: Set PackageName -> Plan -> Plan
stripNonDeps deps plan = plan
  { planTasks = Map.filter checkTask $ planTasks plan
  , planFinals = Map.empty
  , planInstallExes = Map.empty -- TODO maybe don't disable this?
  }
 where
  checkTask task = taskProvides task `Set.member` missingForDeps
  providesDep task = pkgName (taskProvides task) `Set.member` deps
  missing = Map.fromList $ map (taskProvides &&& tcoMissing . taskConfigOpts) $
            Map.elems (planTasks plan)
  missingForDeps = flip execState mempty $
    for_ (Map.elems $ planTasks plan) $ \task ->
      when (providesDep task) $
        collectMissing mempty (taskProvides task)

  collectMissing dependents pid = do
    when (pid `elem` dependents) $
      impureThrow $ TaskCycleBug pid
    modify' (<> Set.singleton pid)
    mapM_ (collectMissing (pid:dependents)) (fromMaybe mempty $ Map.lookup pid missing)

-- | Is the given package/version combo defined in the snapshot or in the global
-- database?
inSnapshot :: PackageName -> Version -> M Bool
inSnapshot name version = do
  ctx <- ask
  pure $ fromMaybe False $ do
    ps <- Map.lookup name (combinedMap ctx)
    case ps of
      PIOnlySource (PSRemote _ srcVersion FromSnapshot _) ->
        pure $ srcVersion == version
      PIBoth (PSRemote _ srcVersion FromSnapshot _) _ ->
        pure $ srcVersion == version
      -- OnlyInstalled occurs for global database
      PIOnlyInstalled loc (Library pid _gid _lic) ->
        assert (loc == Snap) $
        assert (pkgVersion pid == version) $
        Just True
      _ -> pure 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 s msg = do
  debugPlan <- view $ globalOptsL.to globalPlanInLog
  when debugPlan $ logDebugS s msg