{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE ViewPatterns          #-}

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

module Stack.Build.ConstructPlan
    ( constructPlan
    ) where

import           Stack.Prelude hiding (Display (..), loadPackage)
import           Control.Monad.RWS.Strict hiding ((<>))
import           Control.Monad.State.Strict (execState)
import           Data.List
import qualified Data.Map.Strict as M
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 qualified Distribution.Text as Cabal
import qualified Distribution.Version as Cabal
import           Distribution.Types.BuildType (BuildType (Configure))
import           Distribution.Types.PackageName (mkPackageName)
import           Distribution.Version (mkVersion)
import           Generics.Deriving.Monoid (memptydefault, mappenddefault)
import           Path (parent)
import qualified RIO
import           Stack.Build.Cache
import           Stack.Build.Haddock
import           Stack.Build.Installed
import           Stack.Build.Source
import           Stack.Constants
import           Stack.Package
import           Stack.PackageDump
import           Stack.SourceMap
import           Stack.Types.Build
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           Stack.Types.Version
import           System.Environment (lookupEnv)
import           System.IO (putStrLn)
import           RIO.PrettyPrint
import           RIO.Process (findExecutable, HasProcessContext (..))

data PackageInfo
    =
      -- | 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.

      PIOnlyInstalled InstallLocation Installed
      -- | This indicates that the package isn't installed, and we know

      -- where to find its source.

    | PIOnlySource PackageSource
      -- | This indicates that the package is installed and we know

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

    | PIBoth PackageSource Installed
    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 b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
    (\PackageName
_ PackageSource
s (InstallLocation, Installed)
i -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i)
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSource -> PackageInfo
PIOnlySource)
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled))

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

type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])

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 -> [Text] -> [Text]
wWarnings :: !([Text] -> [Text])
    -- ^ 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 StackT

    Ctx
    W
    (Map PackageName (Either ConstructPlanException AddDepRes))
    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
instance HasGHCVariant Ctx
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
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
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 commandline.

--

-- 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
$ [Char] -> StyleDoc
flow [Char]
"You are trying to upgrade/downgrade base, which is almost certainly not what you really want. Please, consider using another GHC version if you need a certain version of base, or removing base from extra-deps. See more at https://github.com/commercialhaskell/stack/issues/3940." 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 <- forall {s}.
(HasBuildConfig s, HasSourceMap s) =>
Version -> RIO s (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 [Text] -> [Text]
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
M.empty
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
RIO.display) ([Text] -> [Text]
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)]
M.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)]
M.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
M.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
M.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
M.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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyErrorNoIndent forall a b. (a -> b) -> a -> b
$
                [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parents (Ctx -> Set PackageName
wanted Ctx
ctx) Map PackageName [PackageName]
prunedGlobalDeps
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [Char] -> StackBuildException
ConstructPlanFailed [Char]
"Plan construction failed."
  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
$ \GlobalPackage
gp ->
      case GlobalPackage
gp of
         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 s (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
            forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp }
      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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
      forall (m :: * -> *) a. Monad m => a -> m a
return 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]

instance Show NotOnlyLocal where
  show :: NotOnlyLocal -> [Char]
show (NotOnlyLocal [PackageName]
packages [Text]
exes) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [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]
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]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
exes)
        , [Char]
"\n"
        ]
    ]
instance Exception NotOnlyLocal

-- | 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)
-> [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_ forall {m :: * -> *}.
MonadState UnregisterState m =>
DumpPackage -> m ()
go [DumpPackage]
keep) UnregisterState
            { usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = Map GhcPkgId (PackageIdentifier, Text)
toUnregister
            , usKeep :: [DumpPackage]
usKeep = []
            , usAnyAdded :: Bool
usAnyAdded = Bool
False
            }

    go :: DumpPackage -> m ()
go DumpPackage
dp = do
        UnregisterState
us <- forall s (m :: * -> *). MonadState s m => m s
get
        case forall {a} {b}.
Ord a =>
Map a (PackageIdentifier, b)
-> PackageIdentifier -> [a] -> Maybe Text
go' (UnregisterState -> Map GhcPkgId (PackageIdentifier, Text)
usToUnregister UnregisterState
us) PackageIdentifier
ident [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
        deps :: [GhcPkgId]
deps = DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp

    go' :: Map a (PackageIdentifier, b)
-> PackageIdentifier -> [a] -> Maybe Text
go' Map a (PackageIdentifier, b)
toUnregister PackageIdentifier
ident [a]
deps
      -- If we're planning on running a task on it, then it must be

      -- unregistered, unless it's 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
name 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
ident
              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
name Map PackageName Text
dirtyReason
      -- Check if a dependency is going to be unregistered

      | (PackageIdentifier
dep, b
_):[(PackageIdentifier, b)]
_ <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map a (PackageIdentifier, b)
toUnregister) [a]
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
        name :: PackageName
        name :: PackageName
name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident

-- | 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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.

--

-- '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
    Ctx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Map PackageName (Either ConstructPlanException AddDepRes)
m <- 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)
m 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 (m :: * -> *) a. Monad m => a -> m a
return Either ConstructPlanException AddDepRes
res
        Maybe (Either ConstructPlanException AddDepRes)
Nothing -> do
            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. [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 (Ctx -> [PackageName]
callStack Ctx
ctx)
                    forall (m :: * -> *) a. Monad m => a -> m a
return 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
                    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
                    forall (m :: * -> *). MonadIO m => [Char] -> m ()
planDebug forall a b. (a -> b) -> a -> b
$ [Char]
"addDep: Package info 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 Maybe PackageInfo
mpackageInfo
                    case Maybe PackageInfo
mpackageInfo of
                        -- TODO look up in the package index and see if there's a

                        -- recommendation available

                        Maybe PackageInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (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

                                      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No latest package revision found for: " forall a. Semigroup a => a -> a -> a
<>
                                          forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", dependency callstack: " forall a. Semigroup a => a -> a -> a
<>
                                          forall a. Show a => a -> Utf8Builder
displayShow (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Ctx -> [PackageName]
callStack Ctx
ctx)
                                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                                    Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) ->
                                      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (m :: * -> *) a. Monad m => a -> m a
return 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
                        Just (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
                        Just (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)
            PackageName
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
updateLibMap PackageName
name Either ConstructPlanException AddDepRes
res
            forall (m :: * -> *) a. Monad m => a -> m a
return Either ConstructPlanException AddDepRes
res

-- 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 (m :: * -> *) a. Monad m => a -> m a
return ()
-- 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. [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. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall 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)
s <- 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 (m :: * -> *) a. Monad m => a -> m a
return (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. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name forall 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 (m :: * -> *) a. Monad m => a -> m a
return 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. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Map PackageName (Either ConstructPlanException AddDepRes)
s
                            forall s (m :: * -> *). MonadState s m => s -> m ()
put Map PackageName (Either ConstructPlanException AddDepRes)
s
                            -- 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        (Maybe Installed
Nothing, Bool
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 lib 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
M.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
M.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
    Map PackageName DepValue
deps' <- Package -> M (Map PackageName DepValue)
packageDepsWithTools 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    else do
                        let warn_ :: Text -> m ()
warn_ Text
reason =
                                forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = (Text
msgforall a. a -> [a] -> [a]
:) }
                              where
                                msg :: Text
msg = [Text] -> Text
T.concat
                                    [ Text
"WARNING: Ignoring "
                                    , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
                                    , Text
"'s bounds on "
                                    , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
depname
                                    , Text
" ("
                                    , VersionRange -> Text
versionRangeText VersionRange
range
                                    , Text
"); using "
                                    , [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
depname (AddDepRes -> Version
adrVersion AddDepRes
adr)
                                    , Text
".\nReason: "
                                    , Text
reason
                                    , Text
"."
                                    ]
                        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
                        if Bool
allowNewer
                            then do
                                forall {m :: * -> *}. MonadWriter W m => Text -> m ()
warn_ Text
"allow-newer enabled"
                                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                            else 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 => Text -> m ()
warn_ Text
"trusting snapshot over cabal file dependency information"
                                        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                    else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                if Bool
inRange
                    then case AddDepRes
adr of
                        ADRToInstall Task
task -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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
M.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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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

    ([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.

packageDepsWithTools :: Package -> M (Map PackageName DepValue)
packageDepsWithTools :: Package -> M (Map PackageName DepValue)
packageDepsWithTools 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = (forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> Text
toolWarningText [ToolWarning]
warnings forall a. [a] -> [a] -> [a]
++) }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Package -> Map PackageName DepValue
packageDeps Package
p

-- | 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 -> Text
toolWarningText :: ToolWarning -> Text
toolWarningText (ToolWarning (ExeName Text
toolName) PackageName
pkgName') =
    Text
"No packages found in snapshot which provide a " forall a. Semigroup a => a -> a -> a
<>
    [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Text
toolName) forall a. Semigroup a => a -> a -> a
<>
    Text
" executable, which is a build-tool dependency of " forall a. Semigroup a => a -> a -> a
<>
    [Char] -> Text
T.pack (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
$ do
      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 a. (?callStack::CallStack) => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
        [Char]
"Unexpected: task cycle for " forall a. Semigroup a => a -> a -> a
<> PackageName -> [Char]
packageNameString (PackageIdentifier -> PackageName
pkgName 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
M.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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False

data ConstructPlanException
    = DependencyCycleDetected [PackageName]
    | DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
    | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all

    -- ^ Recommend adding to extra-deps, give a helpful version number?

    deriving (Typeable, ConstructPlanException -> ConstructPlanException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructPlanException -> ConstructPlanException -> Bool
$c/= :: ConstructPlanException -> ConstructPlanException -> Bool
== :: ConstructPlanException -> ConstructPlanException -> Bool
$c== :: ConstructPlanException -> ConstructPlanException -> Bool
Eq, Int -> ConstructPlanException -> ShowS
[ConstructPlanException] -> ShowS
ConstructPlanException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConstructPlanException] -> ShowS
$cshowList :: [ConstructPlanException] -> ShowS
show :: ConstructPlanException -> [Char]
$cshow :: ConstructPlanException -> [Char]
showsPrec :: Int -> ConstructPlanException -> ShowS
$cshowsPrec :: Int -> ConstructPlanException -> ShowS
Show)

-- | The latest applicable version and it's latest cabal file revision.

-- For display purposes only, Nothing if package not found

type LatestApplicableVersion = Maybe (Version, BlobKey)

-- | Reason why a dependency was not used

data BadDependency
    = NotInBuildPlan
    | Couldn'tResolveItsDependencies Version
    | DependencyMismatch Version
    | HasNoLibrary
    -- ^ See description of 'DepType'

    | BDDependencyCycleDetected ![PackageName]
    deriving (Typeable, BadDependency -> BadDependency -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BadDependency -> BadDependency -> Bool
$c/= :: BadDependency -> BadDependency -> Bool
== :: BadDependency -> BadDependency -> Bool
$c== :: BadDependency -> BadDependency -> Bool
Eq, Eq BadDependency
BadDependency -> BadDependency -> Bool
BadDependency -> BadDependency -> Ordering
BadDependency -> BadDependency -> BadDependency
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BadDependency -> BadDependency -> BadDependency
$cmin :: BadDependency -> BadDependency -> BadDependency
max :: BadDependency -> BadDependency -> BadDependency
$cmax :: BadDependency -> BadDependency -> BadDependency
>= :: BadDependency -> BadDependency -> Bool
$c>= :: BadDependency -> BadDependency -> Bool
> :: BadDependency -> BadDependency -> Bool
$c> :: BadDependency -> BadDependency -> Bool
<= :: BadDependency -> BadDependency -> Bool
$c<= :: BadDependency -> BadDependency -> Bool
< :: BadDependency -> BadDependency -> Bool
$c< :: BadDependency -> BadDependency -> Bool
compare :: BadDependency -> BadDependency -> Ordering
$ccompare :: BadDependency -> BadDependency -> Ordering
Ord, Int -> BadDependency -> ShowS
[BadDependency] -> ShowS
BadDependency -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BadDependency] -> ShowS
$cshowList :: [BadDependency] -> ShowS
show :: BadDependency -> [Char]
$cshow :: BadDependency -> [Char]
showsPrec :: Int -> BadDependency -> ShowS
$cshowsPrec :: Int -> BadDependency -> ShowS
Show)

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

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


pprintExceptions
    :: [ConstructPlanException]
    -> Path Abs File
    -> Path Abs Dir
    -> ParentMap
    -> Set PackageName
    -> Map PackageName [PackageName]
    -> StyleDoc
pprintExceptions :: [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions [ConstructPlanException]
exceptions Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parentMap Set PackageName
wanted' Map PackageName [PackageName]
prunedGlobalDeps =
    forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
      [ [Char] -> StyleDoc
flow [Char]
"While constructing the build plan, the following exceptions were encountered:"
      , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      , forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse (StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConstructPlanException -> Maybe StyleDoc
pprintException [ConstructPlanException]
exceptions'))
      , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      , [Char] -> StyleDoc
flow [Char]
"Some different approaches to resolving this:"
      , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      ] forall a. [a] -> [a] -> [a]
++
      (if Bool -> Bool
not Bool
onlyHasDependencyMismatches then [] else
         [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"Set 'allow-newer: true' in " StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty (Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot) StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"to ignore all version constraints and build anyway.")
         , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
         ]
      ) forall a. [a] -> [a] -> [a]
++ [StyleDoc]
addExtraDepsRecommendations

  where
    exceptions' :: [ConstructPlanException]
exceptions' = {- should we dedupe these somehow? nubOrd -} [ConstructPlanException]
exceptions

    addExtraDepsRecommendations :: [StyleDoc]
addExtraDepsRecommendations
      | forall k a. Map k a -> Bool
Map.null Map PackageName (Version, BlobKey)
extras = []
      | (Just (Version, BlobKey)
_) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> PackageName
mkPackageName [Char]
"base") Map PackageName (Version, BlobKey)
extras =
          [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.")
           , StyleDoc
line
          ]
      | Bool
otherwise =
         [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align
           (Style -> StyleDoc -> StyleDoc
style Style
Recommendation ([Char] -> StyleDoc
flow [Char]
"Recommended action:") StyleDoc -> StyleDoc -> StyleDoc
<+>
            [Char] -> StyleDoc
flow [Char]
"try adding the following to your extra-deps in" StyleDoc -> StyleDoc -> StyleDoc
<+>
            forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
         , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
         , [StyleDoc] -> StyleDoc
vsep (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. IsString a => (PackageName, (Version, BlobKey)) -> a
pprintExtra (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Version, BlobKey)
extras))
         , StyleDoc
line
         ]

    extras :: Map PackageName (Version, BlobKey)
extras = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras [ConstructPlanException]
exceptions'
    getExtras :: ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras DependencyCycleDetected{} = forall k a. Map k a
Map.empty
    getExtras UnknownPackage{} = forall k a. Map k a
Map.empty
    getExtras (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
       forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {k} {a} {a} {b}.
(k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m
     where
       -- TODO: Likely a good idea to distinguish these to the user.  In particular, for DependencyMismatch

       go :: (k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go (k
name, (a
_range, Just (a
version,b
cabalHash), BadDependency
NotInBuildPlan)) =
           forall k a. k -> a -> Map k a
Map.singleton k
name (a
version,b
cabalHash)
       go (k
name, (a
_range, Just (a
version,b
cabalHash), DependencyMismatch{})) =
           forall k a. k -> a -> Map k a
Map.singleton k
name (a
version, b
cabalHash)
       go (k, (a, Maybe (a, b), BadDependency))
_ = forall k a. Map k a
Map.empty
    pprintExtra :: (PackageName, (Version, BlobKey)) -> a
pprintExtra (PackageName
name, (Version
version, BlobKey SHA256
cabalHash FileSize
cabalSize)) =
      let cfInfo :: CabalFileInfo
cfInfo = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
cabalHash (forall a. a -> Maybe a
Just FileSize
cabalSize)
          packageIdRev :: PackageIdentifierRevision
packageIdRev = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfInfo
       in forall a. IsString a => [Char] -> a
fromString ([Char]
"- " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Utf8Builder -> Text
utf8BuilderToText (forall a. Display a => a -> Utf8Builder
RIO.display PackageIdentifierRevision
packageIdRev)))

    allNotInBuildPlan :: Set PackageName
allNotInBuildPlan = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructPlanException -> [PackageName]
toNotInBuildPlan [ConstructPlanException]
exceptions'
    toNotInBuildPlan :: ConstructPlanException -> [PackageName]
toNotInBuildPlan (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
      forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName
_, (VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
badDep)) -> BadDependency
badDep forall a. Eq a => a -> a -> Bool
== BadDependency
NotInBuildPlan) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps
    toNotInBuildPlan ConstructPlanException
_ = []

    -- This checks if 'allow-newer: true' could resolve all issues.

    onlyHasDependencyMismatches :: Bool
onlyHasDependencyMismatches = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructPlanException -> Bool
go [ConstructPlanException]
exceptions'
      where
        go :: ConstructPlanException -> Bool
go DependencyCycleDetected{} = Bool
False
        go UnknownPackage{} = Bool
False
        go (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
depErr) -> BadDependency -> Bool
isMismatch BadDependency
depErr) (forall k a. Map k a -> [a]
M.elems Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m)
        isMismatch :: BadDependency -> Bool
isMismatch DependencyMismatch{} = Bool
True
        isMismatch Couldn'tResolveItsDependencies{} = Bool
True
        isMismatch BadDependency
_ = Bool
False

    pprintException :: ConstructPlanException -> Maybe StyleDoc
pprintException (DependencyCycleDetected [PackageName]
pNames) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        [Char] -> StyleDoc
flow [Char]
"Dependency cycle detected in packages:" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
        Int -> StyleDoc -> StyleDoc
indent Int
4 (StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"[" StyleDoc
"]" StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) [PackageName]
pNames))
    pprintException (DependencyPlanFailures Package
pkg Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
        case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}.
(PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) of
            [] -> forall a. Maybe a
Nothing
            [StyleDoc]
depErrors -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                [Char] -> StyleDoc
flow [Char]
"In the dependencies for" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgIdent forall a. Semigroup a => a -> a -> a
<>
                Map FlagName Bool -> StyleDoc
pprintFlags (Package -> Map FlagName Bool
packageFlags Package
pkg) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                Int -> StyleDoc -> StyleDoc
indent Int
4 ([StyleDoc] -> StyleDoc
vsep [StyleDoc]
depErrors) forall a. Semigroup a => a -> a -> a
<>
                case ParentMap
-> Set PackageName -> PackageName -> Maybe [PackageIdentifier]
getShortestDepsPath ParentMap
parentMap Set PackageName
wanted' (Package -> PackageName
packageName Package
pkg) of
                    Maybe [PackageIdentifier]
Nothing -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"needed for unknown reason - stack invariant violated."
                    Just [] -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"needed since" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgName' StyleDoc -> StyleDoc -> StyleDoc
<+> [Char] -> StyleDoc
flow [Char]
"is a build target."
                    Just (PackageIdentifier
target:[PackageIdentifier]
path) -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"needed due to" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
" -> " [StyleDoc]
pathElems
                      where
                        pathElems :: [StyleDoc]
pathElems =
                            [Style -> StyleDoc -> StyleDoc
style Style
Target forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ PackageIdentifier
target] forall a. [a] -> [a] -> [a]
++
                            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
. PackageIdentifier -> [Char]
packageIdentifierString) [PackageIdentifier]
path forall a. [a] -> [a] -> [a]
++
                            [StyleDoc
pkgIdent]
              where
                pkgName' :: StyleDoc
pkgName' = Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
pkg
                pkgIdent :: StyleDoc
pkgIdent = Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ Package -> PackageIdentifier
packageIdentifier Package
pkg
    -- Skip these when they are redundant with 'NotInBuildPlan' info.

    pprintException (UnknownPackage PackageName
name)
        | PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
allNotInBuildPlan = forall a. Maybe a
Nothing
        | PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Can't build a package with same name as a wired-in-package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ PackageName
name)
        | Just [PackageName]
pruned <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName [PackageName]
prunedGlobalDeps =
            let prunedDeps :: [StyleDoc]
prunedDeps = forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) [PackageName]
pruned
            in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Can't use GHC boot package" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
                      [Char] -> StyleDoc
flow [Char]
"when it has an overridden dependency (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      [Char] -> StyleDoc
flow [Char]
"you need to add the following as explicit dependencies to the project:" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
", " [StyleDoc]
prunedDeps
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Unknown package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ PackageName
name)

    pprintFlags :: Map FlagName Bool -> StyleDoc
pprintFlags Map FlagName Bool
flags
        | forall k a. Map k a -> Bool
Map.null Map FlagName Bool
flags = StyleDoc
""
        | Bool
otherwise = StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Semigroup a, IsString a) => (FlagName, Bool) -> a
pprintFlag forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
flags
    pprintFlag :: (FlagName, Bool) -> a
pprintFlag (FlagName
name, Bool
True) = a
"+" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (FlagName -> [Char]
flagNameString FlagName
name)
    pprintFlag (FlagName
name, Bool
False) = a
"-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (FlagName -> [Char]
flagNameString FlagName
name)

    pprintDep :: (PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (PackageName
name, (VersionRange
range, Maybe (Version, b)
mlatestApplicable, BadDependency
badDep)) = case BadDependency
badDep of
        BadDependency
NotInBuildPlan
          | PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map PackageName [PackageName]
prunedGlobalDeps -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
              Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
              StyleDoc -> StyleDoc
align ((if VersionRange
range forall a. Eq a => a -> a -> Bool
== VersionRange
Cabal.anyVersion
                        then [Char] -> StyleDoc
flow [Char]
"needed"
                        else [Char] -> StyleDoc
flow [Char]
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
                     [Char] -> StyleDoc
flow [Char]
"but this GHC boot package has been pruned (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     [Char] -> StyleDoc
flow [Char]
"you need to add the package explicitly to extra-deps" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     Maybe Version -> StyleDoc
latestApplicable forall a. Maybe a
Nothing)
          | Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
              Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
              StyleDoc -> StyleDoc
align ((if VersionRange
range forall a. Eq a => a -> a -> Bool
== VersionRange
Cabal.anyVersion
                        then [Char] -> StyleDoc
flow [Char]
"needed"
                        else [Char] -> StyleDoc
flow [Char]
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
                     [Char] -> StyleDoc
flow [Char]
"but the stack configuration has no specified version" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     Maybe Version -> StyleDoc
latestApplicable forall a. Maybe a
Nothing)
        -- TODO: For local packages, suggest editing constraints

        DependencyMismatch Version
version -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            (Style -> StyleDoc -> StyleDoc
style Style
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString) (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"from stack configuration does not match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange StyleDoc -> StyleDoc -> StyleDoc
<+>
                   Maybe Version -> StyleDoc
latestApplicable (forall a. a -> Maybe a
Just Version
version))
        -- I think the main useful info is these explain why missing

        -- packages are needed. Instead lets give the user the shortest

        -- path from a target to the package.

        Couldn'tResolveItsDependencies Version
_version -> forall a. Maybe a
Nothing
        BadDependency
HasNoLibrary -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow [Char]
"is a library dependency, but the package provides no library")
        BDDependencyCycleDetected [PackageName]
names -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align ([Char] -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ [Char]
"dependency cycle detected: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString [PackageName]
names))
      where
        goodRange :: StyleDoc
goodRange = Style -> StyleDoc -> StyleDoc
style Style
Good (forall a. IsString a => [Char] -> a
fromString (forall a. Pretty a => a -> [Char]
Cabal.display VersionRange
range))
        latestApplicable :: Maybe Version -> StyleDoc
latestApplicable Maybe Version
mversion =
            case Maybe (Version, b)
mlatestApplicable of
                Maybe (Version, b)
Nothing
                    | forall a. Maybe a -> Bool
isNothing Maybe Version
mversion ->
                        [Char] -> StyleDoc
flow [Char]
"(no package with that name found, perhaps there is a typo in a package's build-depends or an omission from the stack.yaml packages list?)"
                    | Bool
otherwise -> StyleDoc
""
                Just (Version
laVer, b
_)
                    | forall a. a -> Maybe a
Just Version
laVer forall a. Eq a => a -> a -> Bool
== Maybe Version
mversion -> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
                        [Char] -> StyleDoc
flow [Char]
"(latest matching version is specified)"
                    | Bool
otherwise -> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
                        [Char] -> StyleDoc
flow [Char]
"(latest matching version is" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
Good (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
laVer) forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"

-- | Get the shortest reason for the package to be in the build plan. In

-- other words, trace the parent dependencies back to a 'wanted'

-- package.

getShortestDepsPath
    :: ParentMap
    -> Set PackageName
    -> PackageName
    -> Maybe [PackageIdentifier]
getShortestDepsPath :: ParentMap
-> Set PackageName -> PackageName -> Maybe [PackageIdentifier]
getShortestDepsPath (MonoidMap Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap) Set PackageName
wanted' PackageName
name =
    if forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted'
        then forall a. a -> Maybe a
Just []
        else case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap of
            Maybe (First Version, [(PackageIdentifier, VersionRange)])
Nothing -> forall a. Maybe a
Nothing
            Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest Int
256 Map PackageName DepsPath
paths0
              where
                paths0 :: Map PackageName DepsPath
paths0 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
ident, VersionRange
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident, PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident)) [(PackageIdentifier, VersionRange)]
parents
  where
    -- The 'paths' map is a map from PackageName to the shortest path

    -- found to get there. It is the frontier of our breadth-first

    -- search of dependencies.

    findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
    findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest Int
fuel Map PackageName DepsPath
_ | Int
fuel forall a. Ord a => a -> a -> Bool
<= Int
0 =
        [PackageName -> Version -> PackageIdentifier
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
"stack-ran-out-of-jet-fuel") ([Int] -> Version
mkVersion [Int
0])]
    findShortest Int
_ Map PackageName DepsPath
paths | forall k a. Map k a -> Bool
M.null Map PackageName DepsPath
paths = []
    findShortest Int
fuel Map PackageName DepsPath
paths =
        case [(PackageName, DepsPath)]
targets of
            [] -> Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest (Int
fuel forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith DepsPath -> DepsPath -> DepsPath
chooseBest forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath [(PackageName, DepsPath)]
recurses
            [(PackageName, DepsPath)]
_ -> let (DepsPath Int
_ Int
_ [PackageIdentifier]
path) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PackageName, DepsPath)]
targets) in [PackageIdentifier]
path
      where
        ([(PackageName, DepsPath)]
targets, [(PackageName, DepsPath)]
recurses) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(PackageName
n, DepsPath
_) -> PackageName
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wanted') (forall k a. Map k a -> [(k, a)]
M.toList Map PackageName DepsPath
paths)
    chooseBest :: DepsPath -> DepsPath -> DepsPath
    chooseBest :: DepsPath -> DepsPath -> DepsPath
chooseBest DepsPath
x DepsPath
y = forall a. Ord a => a -> a -> a
max DepsPath
x DepsPath
y
    -- Extend a path to all its parents.

    extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
    extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath (PackageName
n, DepsPath
dp) =
        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
n Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap of
            Maybe (First Version, [(PackageIdentifier, VersionRange)])
Nothing -> []
            Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
pkgId, VersionRange
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId, PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath PackageIdentifier
pkgId DepsPath
dp)) [(PackageIdentifier, VersionRange)]
parents

data DepsPath = DepsPath
    { DepsPath -> Int
dpLength :: Int -- ^ Length of dpPath

    , DepsPath -> Int
dpNameLength :: Int -- ^ Length of package names combined

    , DepsPath -> [PackageIdentifier]
dpPath :: [PackageIdentifier] -- ^ A path where the packages later

                                    -- in the list depend on those that

                                    -- come earlier

    }
    deriving (DepsPath -> DepsPath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DepsPath -> DepsPath -> Bool
$c/= :: DepsPath -> DepsPath -> Bool
== :: DepsPath -> DepsPath -> Bool
$c== :: DepsPath -> DepsPath -> Bool
Eq, Eq DepsPath
DepsPath -> DepsPath -> Bool
DepsPath -> DepsPath -> Ordering
DepsPath -> DepsPath -> DepsPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DepsPath -> DepsPath -> DepsPath
$cmin :: DepsPath -> DepsPath -> DepsPath
max :: DepsPath -> DepsPath -> DepsPath
$cmax :: DepsPath -> DepsPath -> DepsPath
>= :: DepsPath -> DepsPath -> Bool
$c>= :: DepsPath -> DepsPath -> Bool
> :: DepsPath -> DepsPath -> Bool
$c> :: DepsPath -> DepsPath -> Bool
<= :: DepsPath -> DepsPath -> Bool
$c<= :: DepsPath -> DepsPath -> Bool
< :: DepsPath -> DepsPath -> Bool
$c< :: DepsPath -> DepsPath -> Bool
compare :: DepsPath -> DepsPath -> Ordering
$ccompare :: DepsPath -> DepsPath -> Ordering
Ord, Int -> DepsPath -> ShowS
[DepsPath] -> ShowS
DepsPath -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DepsPath] -> ShowS
$cshowList :: [DepsPath] -> ShowS
show :: DepsPath -> [Char]
$cshow :: DepsPath -> [Char]
showsPrec :: Int -> DepsPath -> ShowS
$cshowsPrec :: Int -> DepsPath -> ShowS
Show)

startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident = DepsPath
    { dpLength :: Int
dpLength = Int
1
    , dpNameLength :: Int
dpNameLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> [Char]
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
    , dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
    }

extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath PackageIdentifier
ident DepsPath
dp = DepsPath
    { dpLength :: Int
dpLength = DepsPath -> Int
dpLength DepsPath
dp forall a. Num a => a -> a -> a
+ Int
1
    , dpNameLength :: Int
dpNameLength = DepsPath -> Int
dpNameLength DepsPath
dp forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> [Char]
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
    , dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
    }

-- 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 (m :: * -> *) a. Monad m => a -> m a
return ()