{-# 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 hiding ( (<>) )
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.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.Runner ( HasRunner (..) )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), FromSnapshot (..)
                   , GlobalPackage (..), SMTargets (..), SourceMap (..)
                   )
import           Stack.Types.Version
                   ( latestApplicableVersion, versionRangeText, withinRange )
import           System.Environment ( lookupEnv )
import           System.IO ( putStrLn )

data PackageInfo
  = PIOnlyInstalled InstallLocation Installed
    -- ^ This indicates that the package is already installed, and that we

    -- shouldn't build it from source. This is only the case for global

    -- packages.

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

    -- find its source.

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

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

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

combineSourceInstalled :: PackageSource
                       -> (InstallLocation, Installed)
                       -> PackageInfo
combineSourceInstalled :: PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
ps (InstallLocation
location, Installed
installed) =
  forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageSource -> Version
psVersion PackageSource
ps forall a. Eq a => a -> a -> Bool
== Installed -> Version
installedVersion Installed
installed) forall a b. (a -> b) -> a -> b
$
    case InstallLocation
location of
      -- Always trust something in the snapshot

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

type CombinedMap = Map PackageName PackageInfo

combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap = forall k a 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
  (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))
  (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ (InstallLocation, Installed)
i -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled (InstallLocation, Installed)
i))
  (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\PackageName
_ PackageSource
s (InstallLocation, Installed)
i -> PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i))

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

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

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

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

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

    -- version

  }
  deriving forall x. Rep W x -> W
forall x. W -> Rep W x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep W x -> W
$cfrom :: forall x. W -> Rep W x
Generic

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

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

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

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

  IO

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

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

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

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

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

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

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

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

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

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

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

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

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

instance HasEnvConfig Ctx where
  envConfigL :: Lens' Ctx EnvConfig
envConfigL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Ctx -> EnvConfig
ctxEnvConfig (\Ctx
x EnvConfig
y -> Ctx
x { ctxEnvConfig :: EnvConfig
ctxEnvConfig = EnvConfig
y })

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

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

--

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

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

-- 'lpWanted' boolean. For extra packages to build, this comes from the

-- @extraToBuild0@ argument of type @Set PackageName@. These are usually

-- packages that have been specified on the command line.

--

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

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

--

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

-- dependencies have changed.

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

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

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

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

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

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

  mkCtx :: EnvConfig
-> Version
-> Map PackageName PackageSource
-> Maybe Curator
-> Text
-> Ctx
mkCtx EnvConfig
econfig Version
globalCabalVersion Map PackageName PackageSource
sources Maybe Curator
mcur Text
pathEnvVar' = Ctx
    { baseConfigOpts :: BaseConfigOpts
baseConfigOpts = BaseConfigOpts
baseConfigOpts0
    , loadPackage :: PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> M Package
loadPackage = \PackageLocationImmutable
w Map FlagName Bool
x [Text]
y [Text]
z -> forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
econfig forall a b. (a -> b) -> a -> b
$
        Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
loadPackage0 PackageLocationImmutable
w Map FlagName Bool
x [Text]
y [Text]
z
    , combinedMap :: CombinedMap
combinedMap = Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap Map PackageName PackageSource
sources InstalledMap
installedMap
    , ctxEnvConfig :: EnvConfig
ctxEnvConfig = EnvConfig
econfig
    , callStack :: [PackageName]
callStack = []
    , wanted :: Set PackageName
wanted = forall k a. Map k a -> Set k
Map.keysSet (SMTargets -> Map PackageName Target
smtTargets forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
    , localNames :: Set PackageName
localNames = forall k a. Map k a -> Set k
Map.keysSet (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap)
    , mcurator :: Maybe Curator
mcurator = Maybe Curator
mcur
    , pathEnvVar :: Text
pathEnvVar = Text
pathEnvVar'
    }

  prunedGlobalDeps :: Map PackageName [PackageName]
prunedGlobalDeps = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$
    \case
      ReplacedGlobalPackage [PackageName]
deps ->
        let pruned :: [PackageName]
pruned = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
inSourceMap) [PackageName]
deps
        in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
pruned then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [PackageName]
pruned
      GlobalPackage Version
_ -> forall a. Maybe a
Nothing

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

  getSources :: Version -> RIO env (Map PackageName PackageSource)
  getSources :: Version -> RIO env (Map PackageName PackageSource)
getSources Version
globalCabalVersion = do
    let loadLocalPackage' :: ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp = do
          LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage ProjectPackage
pp
          let lpPackage' :: Package
lpPackage' =
                Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
          forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Package
lpPackage' }
    Map PackageName PackageSource
pPackages <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
      LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
    BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> BuildOpts
configBuild
    Map PackageName PackageSource
deps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
      case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
        PLImmutable PackageLocationImmutable
loc ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            PackageLocationImmutable
-> Version -> FromSnapshot -> CommonPackage -> PackageSource
PSRemote PackageLocationImmutable
loc (PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
loc) (DepPackage -> FromSnapshot
dpFromSnapshot DepPackage
dp) (DepPackage -> CommonPackage
dpCommon DepPackage
dp)
        PLMutable ResolvedPath Dir
dir -> do
          ProjectPackage
pp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
dir (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)
          LocalPackage
lp <- forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map PackageName PackageSource
pPackages forall a. Semigroup a => a -> a -> a
<> Map PackageName PackageSource
deps

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

errorOnSnapshot :: Plan -> RIO env Plan
errorOnSnapshot :: forall env. Plan -> RIO env Plan
errorOnSnapshot plan :: Plan
plan@(Plan Map PackageName Task
tasks Map PackageName Task
_finals Map GhcPkgId (PackageIdentifier, Text)
_unregister Map Text InstallLocation
installExes) = do
  let snapTasks :: [PackageName]
snapTasks = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Task
t -> Task -> InstallLocation
taskLocation Task
t forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) Map PackageName Task
tasks
  let snapExes :: [Text]
snapExes = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) Map Text InstallLocation
installExes
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
snapTasks Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
snapExes) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
    [PackageName] -> [Text] -> NotOnlyLocal
NotOnlyLocal [PackageName]
snapTasks [Text]
snapExes
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Plan
plan

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

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

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

-- to unregister.

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

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

-- already registered local packages.

mkUnregisterLocal ::
     Map PackageName Task
     -- ^ Tasks

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

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

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

     -- unregister target packages.

  -> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal :: Map PackageName Task
-> Map PackageName Text
-> [DumpPackage]
-> Bool
-> Map GhcPkgId (PackageIdentifier, Text)
mkUnregisterLocal Map PackageName Task
tasks Map PackageName Text
dirtyReason [DumpPackage]
localDumpPkgs Bool
initialBuildSteps =
  -- We'll take multiple passes through the local packages. This will allow us

  -- to detect that a package should be unregistered, as well as all packages

  -- directly or transitively depending on it.

  Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop forall k a. Map k a
Map.empty [DumpPackage]
localDumpPkgs
 where
  loop ::
       Map GhcPkgId (PackageIdentifier, Text)
       -- ^ Current local packages to unregister.

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

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

  loop :: Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop Map GhcPkgId (PackageIdentifier, Text)
toUnregister [DumpPackage]
keep
    -- If any new packages were added to the unregister Map, we need to loop

    -- through the remaining packages again to detect if a transitive dependency

    -- is being unregistered.

    | UnregisterState -> Bool
usAnyAdded UnregisterState
us = Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Map GhcPkgId (PackageIdentifier, Text)
loop (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) (UnregisterState -> [DumpPackage]
usKeep UnregisterState
us)
    -- Nothing added, so we've already caught them all. Return the Map we've

    -- already calculated.

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

    -- we'll be keeping.

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

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

      Maybe Text
Nothing -> forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us { usKeep :: [DumpPackage]
usKeep = DumpPackage
dp forall a. a -> [a] -> [a]
: UnregisterState -> [DumpPackage]
usKeep UnregisterState
us }
      -- Unregistering, add it to the unregister Map; and indicate that a

      -- package was in fact added to the unregister Map, so we loop again.

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

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

    -> PackageIdentifier
       -- ^ Package identifier.

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

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

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

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

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

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

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

    -- being done.

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

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

    | Bool
otherwise = forall a. Maybe a
Nothing
    where
      -- 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 = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) PackageIdentifier -> PackageName
pkgName Maybe PackageIdentifier
mParentLibId

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

-- tests and benchmarks.

--

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

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

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

--

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

-- @isAllInOne@ is 'True' (the common case), then all of these should have

-- already been taken care of as part of the build step.

addFinal :: LocalPackage -> Package -> Bool -> Bool -> M ()
addFinal :: LocalPackage
-> Package
-> Bool
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
addFinal LocalPackage
lp Package
package Bool
isAllInOne Bool
buildHaddocks = do
  Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
depsRes <- Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package
  Either ConstructPlanException Task
res <- case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
depsRes of
    Left ConstructPlanException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ConstructPlanException
e
    Right (Set PackageIdentifier
missing, Map PackageIdentifier GhcPkgId
present, IsMutable
_minLoc) -> do
      Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Task
        { taskProvides :: PackageIdentifier
taskProvides = PackageName -> Version -> PackageIdentifier
PackageIdentifier
            (Package -> PackageName
packageName Package
package)
            (Package -> Version
packageVersion Package
package)
        , taskConfigOpts :: TaskConfigOpts
taskConfigOpts = Set PackageIdentifier
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
TaskConfigOpts Set PackageIdentifier
missing forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
            let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
present Map PackageIdentifier GhcPkgId
missing'
            in  EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
                  (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
                  (Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
                  Map PackageIdentifier GhcPkgId
allDeps
                  Bool
True -- local

                  IsMutable
Mutable
                  Package
package
        , taskBuildHaddock :: Bool
taskBuildHaddock = Bool
buildHaddocks
        , taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = Map PackageIdentifier GhcPkgId
present
        , taskType :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
        , taskAllInOne :: Bool
taskAllInOne = Bool
isAllInOne
        , taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = [Char] -> CachePkgSrc
CacheSrcLocal (forall b t. Path b t -> [Char]
toFilePath (forall b t. Path b t -> Path b Dir
parent (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)))
        , taskAnyMissing :: Bool
taskAnyMissing = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
        , taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
        }
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wFinals :: Map PackageName (Either ConstructPlanException Task)
wFinals = forall k a. k -> a -> Map k a
Map.singleton (Package -> PackageName
packageName Package
package) Either ConstructPlanException Task
res }

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

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

addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)
addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)
addDep PackageName
name = do
  Map PackageName (Either ConstructPlanException AddDepRes)
libMap <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
libMap of
    Just Either ConstructPlanException AddDepRes
res -> do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
        [Char]
"addDep: Using cached result for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Either ConstructPlanException AddDepRes
res
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res
    Maybe (Either ConstructPlanException AddDepRes)
Nothing -> PackageName -> M (Either ConstructPlanException AddDepRes)
addDep' PackageName
name

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

-- First checks that the package name is not already in the call stack.

addDep' :: PackageName -> M (Either ConstructPlanException AddDepRes)
addDep' :: PackageName -> M (Either ConstructPlanException AddDepRes)
addDep' PackageName
name = do
  Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let mpackageInfo :: Maybe PackageInfo
mpackageInfo = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name forall a b. (a -> b) -> a -> b
$ Ctx -> CombinedMap
combinedMap Ctx
ctx
  Either ConstructPlanException AddDepRes
res <- if PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Ctx -> [PackageName]
callStack Ctx
ctx
    then do
      forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
           [Char]
"addDep': Detected cycle "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
        forall a. Semigroup a => a -> a -> a
<> [Char]
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Ctx -> [PackageName]
callStack Ctx
ctx)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [PackageName] -> ConstructPlanException
DependencyCycleDetected forall a b. (a -> b) -> a -> b
$ PackageName
name forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx
    else forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Ctx
ctx' -> Ctx
ctx' { callStack :: [PackageName]
callStack = PackageName
name forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx' }) forall a b. (a -> b) -> a -> b
$ do
      case Maybe PackageInfo
mpackageInfo of
        -- TODO look up in the package index and see if there's a

        -- recommendation available

        Maybe PackageInfo
Nothing -> do
          forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
               [Char]
"addDep': No package info for "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PackageName -> ConstructPlanException
UnknownPackage PackageName
name
        Just PackageInfo
packageInfo -> PackageName
-> PackageInfo -> M (Either ConstructPlanException AddDepRes)
addDep'' PackageName
name PackageInfo
packageInfo
  PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res

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

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

-- stack is the current package name.

addDep'' ::
     PackageName
  -> PackageInfo
  -> M (Either ConstructPlanException AddDepRes)
addDep'' :: PackageName
-> PackageInfo -> M (Either ConstructPlanException AddDepRes)
addDep'' PackageName
name PackageInfo
packageInfo = do
  forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
       [Char]
"addDep'': Package info for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
    forall a. Semigroup a => a -> a -> a
<> [Char]
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageInfo
packageInfo
  case PackageInfo
packageInfo of
    PIOnlyInstalled InstallLocation
loc Installed
installed -> do
      -- FIXME Slightly hacky, no flags since they likely won't affect

      -- executable names. This code does not feel right.

      let version :: Version
version = Installed -> Version
installedVersion Installed
installed
          askPkgLoc :: RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Maybe PackageLocationImmutable)
askPkgLoc = forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m) =>
RIO env a -> m a
liftRIO forall a b. (a -> b) -> a -> b
$ do
            Maybe (Revision, BlobKey, TreeKey)
mrev <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
            case Maybe (Revision, BlobKey, TreeKey)
mrev of
              Maybe (Revision, BlobKey, TreeKey)
Nothing -> do
                -- This could happen for GHC boot libraries missing from

                -- Hackage.

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

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

tellExecutables :: PackageName -> PackageSource -> M ()
tellExecutables :: PackageName
-> PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutables PackageName
_name (PSFilePath LocalPackage
lp)
  | LocalPackage -> Bool
lpWanted LocalPackage
lp = InstallLocation
-> Package
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutablesPackage InstallLocation
Local forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
-- Ignores ghcOptions because they don't matter for enumerating executables.

tellExecutables PackageName
name (PSRemote PackageLocationImmutable
pkgloc Version
_version FromSnapshot
_fromSnapshot CommonPackage
cp) =
  PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutablesUpstream PackageName
name (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just PackageLocationImmutable
pkgloc) InstallLocation
Snap (CommonPackage -> Map FlagName Bool
cpFlags CommonPackage
cp)

tellExecutablesUpstream ::
     PackageName
  -> M (Maybe PackageLocationImmutable)
  -> InstallLocation
  -> Map FlagName Bool
  -> M ()
tellExecutablesUpstream :: PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
-> InstallLocation
-> Map FlagName Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutablesUpstream PackageName
name RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Maybe PackageLocationImmutable)
retrievePkgLoc InstallLocation
loc Map FlagName Bool
flags = do
  Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Ctx -> Set PackageName
wanted Ctx
ctx) forall a b. (a -> b) -> a -> b
$ do
    Maybe PackageLocationImmutable
mPkgLoc <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Maybe PackageLocationImmutable)
retrievePkgLoc
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PackageLocationImmutable
mPkgLoc forall a b. (a -> b) -> a -> b
$ \PackageLocationImmutable
pkgLoc -> do
      Package
p <- Ctx
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> M Package
loadPackage Ctx
ctx PackageLocationImmutable
pkgLoc Map FlagName Bool
flags [] []
      InstallLocation
-> Package
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
tellExecutablesPackage InstallLocation
loc Package
p

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

  let myComps :: Set Text
myComps =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Package -> PackageName
packageName Package
p) CombinedMap
cm of
          Maybe PackageInfo
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a. Set a
Set.empty
          Just (PIOnlyInstalled InstallLocation
_ Installed
_) -> forall a. Set a
Set.empty
          Just (PIOnlySource PackageSource
ps) -> PackageSource -> Set Text
goSource PackageSource
ps
          Just (PIBoth PackageSource
ps Installed
_) -> PackageSource -> Set Text
goSource PackageSource
ps

      goSource :: PackageSource -> Set Text
goSource (PSFilePath LocalPackage
lp)
        | LocalPackage -> Bool
lpWanted LocalPackage
lp = Set NamedComponent -> Set Text
exeComponents (LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)
        | Bool
otherwise = forall a. Set a
Set.empty
      goSource PSRemote{} = forall a. Set a
Set.empty

  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty
    { wInstall :: Map Text InstallLocation
wInstall = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (, InstallLocation
loc) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall {a}. Ord a => Set a -> Set a -> Set a
filterComps Set Text
myComps forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageExes Package
p
    }
 where
  filterComps :: Set a -> Set a -> Set a
filterComps Set a
myComps Set a
x
    | forall a. Set a -> Bool
Set.null Set a
myComps = Set a
x
    | Bool
otherwise = forall {a}. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
x Set a
myComps

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

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

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

          -- the writer action + reset the state if it fails.

          Map PackageName (Either ConstructPlanException AddDepRes)
libMap <- forall s (m :: * -> *). MonadState s m => m s
get
          Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall a b. (a -> b) -> a -> b
$ do
            Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
tb
            let writerFunc :: a -> a
writerFunc a
w = case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
                  Left ConstructPlanException
_ -> forall a. Monoid a => a
mempty
                  Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
_ -> a
w
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res, forall {a}. Monoid a => a -> a
writerFunc)
          case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
            Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps -> do
              forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$
                   [Char]
"installPackage: For "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PackageName
name
                forall a. Semigroup a => a -> a -> a
<> [Char]
", successfully added package deps"
              -- in curator builds we can't do all-in-one build as

              -- test/benchmark failure could prevent library from being

              -- available to its dependencies but when it's already available

              -- it's OK to do that

              Bool
splitRequired <- Maybe Curator -> Bool
expectedTestOrBenchFailures forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Maybe Curator
mcurator
              let isAllInOne :: Bool
isAllInOne = Bool -> Bool
not Bool
splitRequired
              AddDepRes
adr <- Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> M AddDepRes
installPackageGivenDeps
                Bool
isAllInOne (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps Package
tb Maybe Installed
minstalled (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps
              let finalAllInOne :: Bool
finalAllInOne = case AddDepRes
adr of
                    ADRToInstall Task
_ | Bool
splitRequired -> Bool
False
                    AddDepRes
_ -> Bool
True
              -- FIXME: this redundantly adds the deps (but they'll all just

              -- get looked up in the map)

              LocalPackage
-> Package
-> Bool
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
addFinal LocalPackage
lp Package
tb Bool
finalAllInOne Bool
False
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right AddDepRes
adr
            Left ConstructPlanException
_ -> do
              -- Reset the state to how it was before attempting to find an

              -- all-in-one build plan.

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

              -- separate step.

              Either ConstructPlanException AddDepRes
res' <- Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall
                Bool
False (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps (LocalPackage -> Package
lpPackage LocalPackage
lp) Maybe Installed
minstalled
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. Either a b -> Bool
isRight Either ConstructPlanException AddDepRes
res') forall a b. (a -> b) -> a -> b
$ do
                -- Insert it into the map so that it's available for addFinal.

                PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res'
                LocalPackage
-> Package
-> Bool
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
addFinal LocalPackage
lp Package
tb Bool
False Bool
False
              forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConstructPlanException AddDepRes
res'
 where
  expectedTestOrBenchFailures :: Maybe Curator -> Bool
expectedTestOrBenchFailures Maybe Curator
maybeCurator = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
    Curator
curator <- Maybe Curator
maybeCurator
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name (Curator -> Set PackageName
curatorExpectTestFailure Curator
curator) Bool -> Bool -> Bool
||
           forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name (Curator -> Set PackageName
curatorExpectBenchmarkFailure Curator
curator)

resolveDepsAndInstall :: Bool
                      -> Bool
                      -> PackageSource
                      -> Package
                      -> Maybe Installed
                      -> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> M (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled = do
  Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package
  case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
    Left ConstructPlanException
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ConstructPlanException
err
    Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps ->
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> M AddDepRes
installPackageGivenDeps
          Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps

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

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

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

installPackageGivenDeps :: Bool
                        -> Bool
                        -> PackageSource
                        -> Package
                        -> Maybe Installed
                        -> ( Set PackageIdentifier
                           , Map PackageIdentifier GhcPkgId
                           , IsMutable )
                        -> M AddDepRes
installPackageGivenDeps :: Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> M AddDepRes
installPackageGivenDeps Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled
  (Set PackageIdentifier
missing, Map PackageIdentifier GhcPkgId
present, IsMutable
minMutable) = do
    let name :: PackageName
name = Package -> PackageName
packageName Package
package
    Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe Installed
mRightVersionInstalled <- case (Maybe Installed
minstalled, forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing) of
      (Just Installed
installed, Bool
True) -> do
        Bool
shouldInstall <-
          PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
shouldInstall then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Installed
installed
      (Just Installed
_, Bool
False) -> do
        let t :: Text
t = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$
                  forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName) (forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing)
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty
          { wDirty :: Map PackageName Text
wDirty =
              forall k a. k -> a -> Map k a
Map.singleton PackageName
name forall a b. (a -> b) -> a -> b
$ Text
"missing dependencies: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis Text
t
          }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      (Maybe Installed
Nothing, Bool
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    let loc :: InstallLocation
loc = PackageSource -> InstallLocation
psLocation PackageSource
ps
        mutable :: IsMutable
mutable = InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc forall a. Semigroup a => a -> a -> a
<> IsMutable
minMutable
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe Installed
mRightVersionInstalled of
      Just Installed
installed -> InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
      Maybe Installed
Nothing -> Task -> AddDepRes
ADRToInstall Task
        { taskProvides :: PackageIdentifier
taskProvides = PackageName -> Version -> PackageIdentifier
PackageIdentifier
            (Package -> PackageName
packageName Package
package)
            (Package -> Version
packageVersion Package
package)
        , taskConfigOpts :: TaskConfigOpts
taskConfigOpts = Set PackageIdentifier
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
TaskConfigOpts Set PackageIdentifier
missing forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
            let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
present Map PackageIdentifier GhcPkgId
missing'
            in  EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
                  (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
                  (Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
                  Map PackageIdentifier GhcPkgId
allDeps
                  (PackageSource -> Bool
psLocal PackageSource
ps)
                  IsMutable
mutable
                  Package
package
        , taskBuildHaddock :: Bool
taskBuildHaddock = Bool
buildHaddocks
        , taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = Map PackageIdentifier GhcPkgId
present
        , taskType :: TaskType
taskType =
            case PackageSource
ps of
              PSFilePath LocalPackage
lp ->
                LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
              PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnapshot CommonPackage
_cp ->
                IsMutable -> Package -> PackageLocationImmutable -> TaskType
TTRemotePackage IsMutable
mutable Package
package PackageLocationImmutable
pkgLoc
        , taskAllInOne :: Bool
taskAllInOne = Bool
isAllInOne
        , taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
        , taskAnyMissing :: Bool
taskAnyMissing = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
        , taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
        }

-- | Is the build type of the package Configure

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

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

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

updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M ()
updateLibMap :: PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
val = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Map PackageName (Either ConstructPlanException AddDepRes)
mp ->
  case (forall k a. Ord k => k -> Map k a -> Maybe a
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)
_ -> 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 forall a. Ord a => a -> a -> Bool
< Int
100 = Text
t
  | Bool
otherwise = Int -> Text -> Text
T.take Int
97 Text
t forall a. Semigroup a => a -> a -> a
<> Text
"..."

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

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

-- figured out during the build, after they've been built. The 2nd part of the

-- tuple result indicates the packages that are already installed which will be

-- used.

--

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

-- parent package must be installed locally. Otherwise, if it is 'Snap', then it

-- can either be installed locally or in the snapshot.

addPackageDeps ::
     Package
  -> M ( Either
           ConstructPlanException
           ( Set PackageIdentifier
           , Map PackageIdentifier GhcPkgId
           , IsMutable
           )
       )
addPackageDeps :: Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package = do
  Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Package
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
checkAndWarnForUnknownTools Package
package
  let deps' :: Map PackageName DepValue
deps' = Package -> Map PackageName DepValue
packageDeps Package
package
  [Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
deps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName DepValue
deps') forall a b. (a -> b) -> a -> b
$ \(PackageName
depname, DepValue VersionRange
range DepType
depType) -> do
    Either ConstructPlanException AddDepRes
eres <- PackageName -> M (Either ConstructPlanException AddDepRes)
addDep PackageName
depname
    let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
        getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev = do
          Map Version (Map Revision BlobKey)
vsAndRevs <-
            forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx forall a b. (a -> b) -> a -> b
$
              forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions
                RequireHackageIndex
YesRequireHackageIndex UsePreferredVersions
UsePreferredVersions PackageName
depname
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
            Version
lappVer <- VersionRange -> Set Version -> Maybe Version
latestApplicableVersion VersionRange
range forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map Version (Map Revision BlobKey)
vsAndRevs
            Map Revision BlobKey
revs <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Version
lappVer Map Version (Map Revision BlobKey)
vsAndRevs
            (BlobKey
cabalHash, Map Revision BlobKey
_) <- forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map Revision BlobKey
revs
            forall a. a -> Maybe a
Just (Version
lappVer, BlobKey
cabalHash)
    case Either ConstructPlanException AddDepRes
eres of
      Left ConstructPlanException
e -> do
        forall {m :: * -> *}.
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range forall a. Maybe a
Nothing
        let bd :: BadDependency
bd = case ConstructPlanException
e of
              UnknownPackage PackageName
name -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageName
name forall a. Eq a => a -> a -> Bool
== PackageName
depname) BadDependency
NotInBuildPlan
              DependencyCycleDetected [PackageName]
names -> [PackageName] -> BadDependency
BDDependencyCycleDetected [PackageName]
names
              -- ultimately we won't show any information on this to the user,

              -- we'll allow the dependency failures alone to display to avoid

              -- spamming the user too much

              DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
_  ->
                Version -> BadDependency
Couldn'tResolveItsDependencies (Package -> Version
packageVersion Package
package)
        Maybe (Version, BlobKey)
mlatestApplicable <- M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
mlatestApplicable, BadDependency
bd))
      Right AddDepRes
adr | DepType
depType forall a. Eq a => a -> a -> Bool
== DepType
AsLibrary Bool -> Bool -> Bool
&& Bool -> Bool
not (AddDepRes -> Bool
adrHasLibrary AddDepRes
adr) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, forall a. Maybe a
Nothing, BadDependency
HasNoLibrary))
      Right AddDepRes
adr -> do
        forall {m :: * -> *}.
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range forall a. Maybe a
Nothing
        Bool
inRange <- if AddDepRes -> Version
adrVersion AddDepRes
adr Version -> VersionRange -> Bool
`withinRange` VersionRange
range
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else do
            let warn_ :: Bool -> StyleDoc -> m ()
warn_ Bool
isIgnoring StyleDoc
reason = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [StyleDoc] -> [StyleDoc]
wWarnings = (StyleDoc
msg:) }
                 where
                  msg :: StyleDoc
msg =
                       [StyleDoc] -> StyleDoc
fillSep
                         [ if Bool
isIgnoring then StyleDoc
"Ignoring" else [Char] -> StyleDoc
flow [Char]
"Not ignoring"
                         , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"'s"
                         , [Char] -> StyleDoc
flow [Char]
"bounds on"
                         , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
depname)
                         , StyleDoc -> StyleDoc
parens (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ VersionRange -> Text
versionRangeText VersionRange
range)
                         , [Char] -> StyleDoc
flow [Char]
"and using"
                         , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$
                             PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                         ]
                    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                         [ StyleDoc
"Reason:"
                         , StyleDoc
reason forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                         ]
            Bool
allowNewer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
            Maybe [PackageName]
allowNewerDeps <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe [PackageName]
configAllowNewerDeps
            let inSnapshotCheck :: RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Bool
inSnapshotCheck = do
                  -- We ignore dependency information for packages in a snapshot

                  Bool
x <- PackageName
-> Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
inSnapshot (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
                  Bool
y <- PackageName
-> Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
inSnapshot PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)
                  if Bool
x Bool -> Bool -> Bool
&& Bool
y
                    then do
                      forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True
                        ( [Char] -> StyleDoc
flow [Char]
"trusting snapshot over Cabal file dependency \
                               \information"
                        )
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            if Bool
allowNewer
              then case Maybe [PackageName]
allowNewerDeps of
                Maybe [PackageName]
Nothing -> do
                  forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
True forall a b. (a -> b) -> a -> b
$
                    [StyleDoc] -> StyleDoc
fillSep
                      [ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
                      , StyleDoc
"enabled"
                      ]
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                Just [PackageName]
boundsIgnoredDeps -> do
                  let pkgName :: PackageName
pkgName = Package -> PackageName
packageName Package
package
                      pkgName' :: StyleDoc
pkgName' = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pkgName
                      isBoundsIgnoreDep :: Bool
isBoundsIgnoreDep = PackageName
pkgName 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"
                          ]
                  forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
isBoundsIgnoreDep StyleDoc
reason
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isBoundsIgnoreDep
              else do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe [PackageName]
allowNewerDeps) forall a b. (a -> b) -> a -> b
$
                  forall {m :: * -> *}. MonadWriter W m => Bool -> StyleDoc -> m ()
warn_ Bool
False forall a b. (a -> b) -> a -> b
$
                    [StyleDoc] -> StyleDoc
fillSep
                      [ StyleDoc
"although"
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-deps"
                      , [Char] -> StyleDoc
flow [Char]
"are specified,"
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer"
                      , StyleDoc
"is"
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"false"
                      ]
                RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Bool
inSnapshotCheck
        if Bool
inRange
          then case AddDepRes
adr of
            ADRToInstall Task
task -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
              ( forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
              , forall k a. Map k a
Map.empty, Task -> IsMutable
taskTargetIsMutable Task
task
              )
            ADRFound InstallLocation
loc (Executable PackageIdentifier
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
              ( forall a. Set a
Set.empty, forall k a. Map k a
Map.empty
              , InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc
              )
            ADRFound InstallLocation
loc (Library PackageIdentifier
ident GhcPkgId
gid Maybe (Either License License)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
              ( forall a. Set a
Set.empty, forall k a. k -> a -> Map k a
Map.singleton PackageIdentifier
ident GhcPkgId
gid
              , InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc
              )
          else do
            Maybe (Version, BlobKey)
mlatestApplicable <- M (Maybe (Version, BlobKey))
getLatestApplicableVersionAndRev
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
              ( PackageName
depname
              , ( VersionRange
range
                , Maybe (Version, BlobKey)
mlatestApplicable
                , Version -> BadDependency
DependencyMismatch forall a b. (a -> b) -> a -> b
$ AddDepRes -> Version
adrVersion AddDepRes
adr
                )
              )
  case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
deps of
    -- Note that the Monoid for 'InstallLocation' means that if any

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

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

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

    -- locally or in the snapshot.

    ([], [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
pairs) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
pairs
    ([(PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))]
errs, [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Package
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> ConstructPlanException
DependencyPlanFailures
      Package
package
      (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))]
errs)
 where
  adrVersion :: AddDepRes -> Version
adrVersion (ADRToInstall Task
task) = PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
  adrVersion (ADRFound InstallLocation
_ Installed
installed) = Installed -> Version
installedVersion Installed
installed
  -- Update the parents map, for later use in plan construction errors

  -- - see 'getShortestDepsPath'.

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

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

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

  -- make sure we consider internal libraries as libraries too

  packageHasLibrary :: Package -> Bool
  packageHasLibrary :: Package -> Bool
packageHasLibrary Package
p =
    Bool -> Bool
not (forall a. Set a -> Bool
Set.null (Package -> Set Text
packageInternalLibraries Package
p)) Bool -> Bool -> Bool
||
    case Package -> PackageLibraries
packageLibraries Package
p of
      HasLibraries Set Text
_ -> Bool
True
      PackageLibraries
NoLibraries -> Bool
False

checkDirtiness :: PackageSource
               -> Installed
               -> Package
               -> Map PackageIdentifier GhcPkgId
               -> Bool
               -> M Bool
checkDirtiness :: PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks = do
  Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe ConfigCache
moldOpts <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Installed -> RIO env (Maybe ConfigCache)
tryGetFlagCache Installed
installed
  let configOpts :: ConfigureOpts
configOpts = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
        (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
        (Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
        Map PackageIdentifier GhcPkgId
present
        (PackageSource -> Bool
psLocal PackageSource
ps)
        (InstallLocation -> IsMutable
installLocationIsMutable forall a b. (a -> b) -> a -> b
$ PackageSource -> InstallLocation
psLocation PackageSource
ps) -- should be Local i.e. mutable always

        Package
package
      wantConfigCache :: ConfigCache
wantConfigCache = ConfigCache
        { configCacheOpts :: ConfigureOpts
configCacheOpts = ConfigureOpts
configOpts
        , configCacheDeps :: Set GhcPkgId
configCacheDeps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
present
        , configCacheComponents :: Set ByteString
configCacheComponents =
            case PackageSource
ps of
              PSFilePath LocalPackage
lp ->
                forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
              PSRemote{} -> forall a. Set a
Set.empty
        , configCacheHaddock :: Bool
configCacheHaddock = Bool
buildHaddocks
        , configCachePkgSrc :: CachePkgSrc
configCachePkgSrc = PackageSource -> CachePkgSrc
toCachePkgSrc PackageSource
ps
        , configCachePathEnvVar :: Text
configCachePathEnvVar = Ctx -> Text
pathEnvVar Ctx
ctx
        }
      config :: Config
config = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL Ctx
ctx
  Maybe Text
mreason <-
    case Maybe ConfigCache
moldOpts of
      Maybe ConfigCache
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"old configure information not found"
      Just ConfigCache
oldOpts
        | Just Text
reason <- Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff Config
config ConfigCache
oldOpts ConfigCache
wantConfigCache ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
reason
        | Bool
True <- PackageSource -> Bool
psForceDirty PackageSource
ps -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"--force-dirty specified"
        | Bool
otherwise -> do
            Maybe (Set [Char])
dirty <- forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set [Char]))
psDirty PackageSource
ps
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              case Maybe (Set [Char])
dirty of
                Just Set [Char]
files -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                     Text
"local file changes: "
                  forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set [Char]
files)
                Maybe (Set [Char])
Nothing -> forall a. Maybe a
Nothing
  case Maybe Text
mreason of
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Text
reason -> do
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wDirty :: Map PackageName Text
wDirty = forall k a. k -> a -> Map k a
Map.singleton (Package -> PackageName
packageName Package
package) Text
reason }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

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

    go' :: WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
wc Text
x [Text]
xs = WhichCompiler -> Text -> [Text] -> [Text]
checkKeepers WhichCompiler
wc Text
x forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
go [Text]
xs

    checkKeepers :: WhichCompiler -> Text -> [Text] -> [Text]
checkKeepers WhichCompiler
wc Text
x [Text]
xs =
      case forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isKeeper forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
x of
        [] -> [Text]
xs
        [Text]
keepers -> [Char] -> Text
T.pack (WhichCompiler -> [Char]
compilerOptionsCabalFlag WhichCompiler
wc) forall a. a -> [a] -> [a]
: [Text] -> Text
T.unwords [Text]
keepers forall a. a -> [a] -> [a]
: [Text]
xs

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

    -- a rebuild

    --

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

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


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

    isStackOpt :: Text -> Bool
    isStackOpt :: Text -> Bool
isStackOpt Text
t = 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 forall a. Eq a => a -> a -> Bool
== Text
"--user"

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

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

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

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

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

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


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

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

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

-- tool dependencies.

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

  [ToolWarning]
warnings <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Package -> Set ExeName
packageUnknownTools Package
p) forall a b. (a -> b) -> a -> b
$
    \name :: ExeName
name@(ExeName Text
toolName) -> do
      let settings :: EnvSettings
settings = EnvSettings
minimalEnvSettings { esIncludeLocals :: Bool
esIncludeLocals = Bool
True }
      Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
      ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
settings
      Either ProcessException [Char]
mfound <- forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
toolName
      case Either ProcessException [Char]
mfound of
        Left ProcessException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExeName -> PackageName -> ToolWarning
ToolWarning ExeName
name (Package -> PackageName
packageName Package
p)
        Right [Char]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [StyleDoc] -> [StyleDoc]
wWarnings = (forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> StyleDoc
toolWarningText [ToolWarning]
warnings ++) }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

-- expected and the package name using it.

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

toolWarningText :: ToolWarning -> 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 (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ 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 (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pkgName')
  ]

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

stripLocals :: Plan -> Plan
stripLocals :: Plan -> Plan
stripLocals Plan
plan = Plan
plan
  { planTasks :: Map PackageName Task
planTasks = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
  , planFinals :: Map PackageName Task
planFinals = forall k a. Map k a
Map.empty
  , planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal = forall k a. Map k a
Map.empty
  , planInstallExes :: Map Text InstallLocation
planInstallExes = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= InstallLocation
Local) forall a b. (a -> b) -> a -> b
$ Plan -> Map Text InstallLocation
planInstallExes Plan
plan
  }
 where
  checkTask :: Task -> Bool
checkTask Task
task = Task -> InstallLocation
taskLocation Task
task forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap

stripNonDeps :: Set PackageName -> Plan -> Plan
stripNonDeps :: Set PackageName -> Plan -> Plan
stripNonDeps Set PackageName
deps Plan
plan = Plan
plan
  { planTasks :: Map PackageName Task
planTasks = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
  , planFinals :: Map PackageName Task
planFinals = forall k a. Map k a
Map.empty
  , planInstallExes :: Map Text InstallLocation
planInstallExes = forall k a. Map k a
Map.empty -- TODO maybe don't disable this?

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

  collectMissing :: [PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
dependents PackageIdentifier
pid = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
pid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageIdentifier]
dependents) forall a b. (a -> b) -> a -> b
$
      forall e a. Exception e => e -> a
impureThrow forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
TaskCycleBug PackageIdentifier
pid
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall a. Semigroup a => a -> a -> a
<> forall a. a -> Set a
Set.singleton PackageIdentifier
pid)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing (PackageIdentifier
pidforall a. a -> [a] -> [a]
:[PackageIdentifier]
dependents)) (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pid Map PackageIdentifier (Set PackageIdentifier)
missing)

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

-- database?

inSnapshot :: PackageName -> Version -> M Bool
inSnapshot :: PackageName
-> Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
inSnapshot PackageName
name Version
version = do
  Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
    PackageInfo
ps <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (Ctx -> CombinedMap
combinedMap Ctx
ctx)
    case PackageInfo
ps of
      PIOnlySource (PSRemote PackageLocationImmutable
_ Version
srcVersion FromSnapshot
FromSnapshot CommonPackage
_) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Version
srcVersion forall a. Eq a => a -> a -> Bool
== Version
version
      PIBoth (PSRemote PackageLocationImmutable
_ Version
srcVersion FromSnapshot
FromSnapshot CommonPackage
_) Installed
_ ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Version
srcVersion forall a. Eq a => a -> a -> Bool
== Version
version
      -- OnlyInstalled occurs for global database

      PIOnlyInstalled InstallLocation
loc (Library PackageIdentifier
pid GhcPkgId
_gid Maybe (Either License License)
_lic) ->
        forall a. (?callStack::CallStack) => Bool -> a -> a
assert (InstallLocation
loc forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) forall a b. (a -> b) -> a -> b
$
        forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pid forall a. Eq a => a -> a -> Bool
== Version
version) forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a
Just Bool
True
      PackageInfo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

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

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


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

planDebug :: MonadIO m => String -> m ()
planDebug :: forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug = if Bool
False then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn else \[Char]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()