{-# 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 -> String
(Int -> PackageInfo -> ShowS)
-> (PackageInfo -> String)
-> ([PackageInfo] -> ShowS)
-> Show PackageInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageInfo] -> ShowS
$cshowList :: [PackageInfo] -> ShowS
show :: PackageInfo -> String
$cshow :: PackageInfo -> String
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) =
    Bool -> PackageInfo -> PackageInfo
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageSource -> Version
psVersion PackageSource
ps Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Installed -> Version
installedVersion Installed
installed) (PackageInfo -> PackageInfo) -> PackageInfo -> PackageInfo
forall a b. (a -> b) -> a -> b
$
    case InstallLocation
location of
        -- Always trust something in the snapshot
        InstallLocation
Snap -> InstallLocation -> Installed -> PackageInfo
PIOnlyInstalled InstallLocation
location Installed
installed
        InstallLocation
Local -> PackageSource -> Installed -> PackageInfo
PIBoth PackageSource
ps Installed
installed

type CombinedMap = Map PackageName PackageInfo

combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
combineMap = (PackageName
 -> PackageSource
 -> (InstallLocation, Installed)
 -> Maybe PackageInfo)
-> (Map PackageName PackageSource -> CombinedMap)
-> (InstalledMap -> CombinedMap)
-> Map PackageName PackageSource
-> InstalledMap
-> CombinedMap
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 -> PackageInfo -> Maybe PackageInfo
forall a. a -> Maybe a
Just (PackageInfo -> Maybe PackageInfo)
-> PackageInfo -> Maybe PackageInfo
forall a b. (a -> b) -> a -> b
$ PackageSource -> (InstallLocation, Installed) -> PackageInfo
combineSourceInstalled PackageSource
s (InstallLocation, Installed)
i)
    ((PackageSource -> PackageInfo)
-> Map PackageName PackageSource -> CombinedMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSource -> PackageInfo
PIOnlySource)
    (((InstallLocation, Installed) -> PackageInfo)
-> InstalledMap -> CombinedMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InstallLocation -> Installed -> PackageInfo)
-> (InstallLocation, Installed) -> PackageInfo
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 -> String
(Int -> AddDepRes -> ShowS)
-> (AddDepRes -> String)
-> ([AddDepRes] -> ShowS)
-> Show AddDepRes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddDepRes] -> ShowS
$cshowList :: [AddDepRes] -> ShowS
show :: AddDepRes -> String
$cshow :: AddDepRes -> String
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. W -> Rep W x) -> (forall x. Rep W x -> W) -> Generic W
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
(<>) = W -> W -> W
forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault
instance Monoid W where
    mempty :: W
mempty = W
forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
    mappend :: W -> W -> W
mappend = W -> W -> W
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 :: (LogFunc -> f LogFunc) -> Ctx -> f Ctx
logFuncL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((LogFunc -> f LogFunc) -> Config -> f Config)
-> (LogFunc -> f LogFunc)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> Config -> f Config
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasRunner Ctx where
    runnerL :: (Runner -> f Runner) -> Ctx -> f Ctx
runnerL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((Runner -> f Runner) -> Config -> f Config)
-> (Runner -> f Runner)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> Config -> f Config
forall env. HasRunner env => Lens' env Runner
runnerL
instance HasStylesUpdate Ctx where
  stylesUpdateL :: (StylesUpdate -> f StylesUpdate) -> Ctx -> f Ctx
stylesUpdateL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((StylesUpdate -> f StylesUpdate) -> Runner -> f Runner)
-> (StylesUpdate -> f StylesUpdate)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> Runner -> f Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasTerm Ctx where
  useColorL :: (Bool -> f Bool) -> Ctx -> f Ctx
useColorL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((Bool -> f Bool) -> Runner -> f Runner)
-> (Bool -> f Bool)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Bool
useColorL
  termWidthL :: (Int -> f Int) -> Ctx -> f Ctx
termWidthL = (Runner -> f Runner) -> Ctx -> f Ctx
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> Ctx -> f Ctx)
-> ((Int -> f Int) -> Runner -> f Runner)
-> (Int -> f Int)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Int
termWidthL
instance HasConfig Ctx
instance HasPantryConfig Ctx where
    pantryConfigL :: (PantryConfig -> f PantryConfig) -> Ctx -> f Ctx
pantryConfigL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((PantryConfig -> f PantryConfig) -> Config -> f Config)
-> (PantryConfig -> f PantryConfig)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> Config -> f Config
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasProcessContext Ctx where
    processContextL :: (ProcessContext -> f ProcessContext) -> Ctx -> f Ctx
processContextL = (Config -> f Config) -> Ctx -> f Ctx
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> Ctx -> f Ctx)
-> ((ProcessContext -> f ProcessContext) -> Config -> f Config)
-> (ProcessContext -> f ProcessContext)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> Config -> f Config
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasBuildConfig Ctx
instance HasSourceMap Ctx where
    sourceMapL :: (SourceMap -> f SourceMap) -> Ctx -> f Ctx
sourceMapL = (EnvConfig -> f EnvConfig) -> Ctx -> f Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL((EnvConfig -> f EnvConfig) -> Ctx -> f Ctx)
-> ((SourceMap -> f SourceMap) -> EnvConfig -> f EnvConfig)
-> (SourceMap -> f SourceMap)
-> Ctx
-> f Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SourceMap -> f SourceMap) -> EnvConfig -> f EnvConfig
forall env. HasSourceMap env => Lens' env SourceMap
sourceMapL
instance HasCompiler Ctx where
    compilerPathsL :: Getting r Ctx CompilerPaths
compilerPathsL = (EnvConfig -> Const r EnvConfig) -> Ctx -> Const r Ctx
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL((EnvConfig -> Const r EnvConfig) -> Ctx -> Const r Ctx)
-> ((CompilerPaths -> Const r CompilerPaths)
    -> EnvConfig -> Const r EnvConfig)
-> Getting r Ctx CompilerPaths
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CompilerPaths -> Const r CompilerPaths)
-> EnvConfig -> Const r EnvConfig
forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsL
instance HasEnvConfig Ctx where
    envConfigL :: (EnvConfig -> f EnvConfig) -> Ctx -> f Ctx
envConfigL = (Ctx -> EnvConfig)
-> (Ctx -> EnvConfig -> Ctx) -> Lens' Ctx EnvConfig
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 :: BaseConfigOpts
-> [DumpPackage]
-> (PackageLocationImmutable
    -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package)
-> SourceMap
-> InstalledMap
-> Bool
-> RIO env Plan
constructPlan BaseConfigOpts
baseConfigOpts0 [DumpPackage]
localDumpPkgs PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
loadPackage0 SourceMap
sourceMap InstalledMap
installedMap Bool
initialBuildSteps = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Constructing the build plan"

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasBaseInDeps (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"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." StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

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

    let onTarget :: PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
onTarget = RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   (Either ConstructPlanException AddDepRes)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> (PackageName
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Either ConstructPlanException AddDepRes))
-> PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
addDep
    let inner :: RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  ()
inner = (PackageName
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> [PackageName]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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 ([PackageName]
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> [PackageName]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ Map PackageName Target -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (SMTargets -> Map PackageName Target
smtTargets (SMTargets -> Map PackageName Target)
-> SMTargets -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
    Text
pathEnvVar' <- IO Text -> RIO env Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> RIO env Text) -> IO Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty String -> Text
T.pack (Maybe String -> Text) -> IO (Maybe String) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"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) <-
        IO
  ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
-> RIO
     env
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
 -> RIO
      env
      ((), Map PackageName (Either ConstructPlanException AddDepRes), W))
-> IO
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
-> RIO
     env
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
forall a b. (a -> b) -> a -> b
$ RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  ()
-> Ctx
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> IO
     ((), Map PackageName (Either ConstructPlanException AddDepRes), W)
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 Map PackageName (Either ConstructPlanException AddDepRes)
forall k a. Map k a
M.empty
    (Text -> RIO env ()) -> [Text] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (Text -> Utf8Builder) -> Text -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
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)  = a -> Either a (a, b)
forall a b. a -> Either a b
Left a
e
        toEither (a
k, Right b
v) = (a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
k, b
v)
        ([ConstructPlanException]
errlibs, [(PackageName, AddDepRes)]
adrs) = [Either ConstructPlanException (PackageName, AddDepRes)]
-> ([ConstructPlanException], [(PackageName, AddDepRes)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ConstructPlanException (PackageName, AddDepRes)]
 -> ([ConstructPlanException], [(PackageName, AddDepRes)]))
-> [Either ConstructPlanException (PackageName, AddDepRes)]
-> ([ConstructPlanException], [(PackageName, AddDepRes)])
forall a b. (a -> b) -> a -> b
$ ((PackageName, Either ConstructPlanException AddDepRes)
 -> Either ConstructPlanException (PackageName, AddDepRes))
-> [(PackageName, Either ConstructPlanException AddDepRes)]
-> [Either ConstructPlanException (PackageName, AddDepRes)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Either ConstructPlanException AddDepRes)
-> Either ConstructPlanException (PackageName, AddDepRes)
forall a a b. (a, Either a b) -> Either a (a, b)
toEither ([(PackageName, Either ConstructPlanException AddDepRes)]
 -> [Either ConstructPlanException (PackageName, AddDepRes)])
-> [(PackageName, Either ConstructPlanException AddDepRes)]
-> [Either ConstructPlanException (PackageName, AddDepRes)]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Either ConstructPlanException AddDepRes)
-> [(PackageName, Either ConstructPlanException AddDepRes)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName (Either ConstructPlanException AddDepRes)
m
        ([ConstructPlanException]
errfinals, [(PackageName, Task)]
finals) = [Either ConstructPlanException (PackageName, Task)]
-> ([ConstructPlanException], [(PackageName, Task)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ConstructPlanException (PackageName, Task)]
 -> ([ConstructPlanException], [(PackageName, Task)]))
-> [Either ConstructPlanException (PackageName, Task)]
-> ([ConstructPlanException], [(PackageName, Task)])
forall a b. (a -> b) -> a -> b
$ ((PackageName, Either ConstructPlanException Task)
 -> Either ConstructPlanException (PackageName, Task))
-> [(PackageName, Either ConstructPlanException Task)]
-> [Either ConstructPlanException (PackageName, Task)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Either ConstructPlanException Task)
-> Either ConstructPlanException (PackageName, Task)
forall a a b. (a, Either a b) -> Either a (a, b)
toEither ([(PackageName, Either ConstructPlanException Task)]
 -> [Either ConstructPlanException (PackageName, Task)])
-> [(PackageName, Either ConstructPlanException Task)]
-> [Either ConstructPlanException (PackageName, Task)]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Either ConstructPlanException Task)
-> [(PackageName, Either ConstructPlanException Task)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName (Either ConstructPlanException Task)
efinals
        errs :: [ConstructPlanException]
errs = [ConstructPlanException]
errlibs [ConstructPlanException]
-> [ConstructPlanException] -> [ConstructPlanException]
forall a. [a] -> [a] -> [a]
++ [ConstructPlanException]
errfinals
    if [ConstructPlanException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructPlanException]
errs
        then do
            let toTask :: (a, AddDepRes) -> Maybe (a, Task)
toTask (a
_, ADRFound InstallLocation
_ Installed
_) = Maybe (a, Task)
forall a. Maybe a
Nothing
                toTask (a
name, ADRToInstall Task
task) = (a, Task) -> Maybe (a, Task)
forall a. a -> Maybe a
Just (a
name, Task
task)
                tasks :: Map PackageName Task
tasks = [(PackageName, Task)] -> Map PackageName Task
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PackageName, Task)] -> Map PackageName Task)
-> [(PackageName, Task)] -> Map PackageName Task
forall a b. (a -> b) -> a -> b
$ ((PackageName, AddDepRes) -> Maybe (PackageName, Task))
-> [(PackageName, AddDepRes)] -> [(PackageName, Task)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName, AddDepRes) -> Maybe (PackageName, Task)
forall a. (a, AddDepRes) -> Maybe (a, Task)
toTask [(PackageName, AddDepRes)]
adrs
                takeSubset :: Plan -> RIO env Plan
takeSubset =
                    case BuildOptsCLI -> BuildSubset
boptsCLIBuildSubset (BuildOptsCLI -> BuildSubset) -> BuildOptsCLI -> BuildSubset
forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI BaseConfigOpts
baseConfigOpts0 of
                        BuildSubset
BSAll -> Plan -> RIO env Plan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        BuildSubset
BSOnlySnapshot -> Plan -> RIO env Plan
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Plan -> RIO env Plan) -> (Plan -> Plan) -> Plan -> RIO env Plan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plan -> Plan
stripLocals
                        BuildSubset
BSOnlyDependencies -> Plan -> RIO env Plan
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Plan -> RIO env Plan) -> (Plan -> Plan) -> Plan -> RIO env Plan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PackageName -> Plan -> Plan
stripNonDeps (Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
M.keysSet (Map PackageName DepPackage -> Set PackageName)
-> Map PackageName DepPackage -> Set PackageName
forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
                        BuildSubset
BSOnlyLocals -> Plan -> RIO env Plan
forall env. Plan -> RIO env Plan
errorOnSnapshot
            Plan -> RIO env Plan
forall env. Plan -> RIO env Plan
takeSubset Plan :: Map PackageName Task
-> Map PackageName Task
-> Map GhcPkgId (PackageIdentifier, Text)
-> Map Text InstallLocation
-> Plan
Plan
                { planTasks :: Map PackageName Task
planTasks = Map PackageName Task
tasks
                , planFinals :: Map PackageName Task
planFinals = [(PackageName, Task)] -> Map PackageName Task
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 Map Text InstallLocation
forall k a. Map k a
Map.empty
                }
        else do
            String -> RIO env ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String -> RIO env ()) -> String -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [ConstructPlanException] -> String
forall a. Show a => a -> String
show [ConstructPlanException]
errs
            Path Abs File
stackYaml <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
            Path Abs Dir
stackRoot <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL
            StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyErrorNoIndent (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
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
            StackBuildException -> RIO env Plan
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackBuildException -> RIO env Plan)
-> StackBuildException -> RIO env Plan
forall a b. (a -> b) -> a -> b
$ String -> StackBuildException
ConstructPlanFailed String
"Plan construction failed."
  where
    hasBaseInDeps :: Bool
hasBaseInDeps = PackageName -> Map PackageName DepPackage -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (String -> PackageName
mkPackageName String
"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
-> (PackageLocationImmutable
    -> Map FlagName Bool -> [Text] -> [Text] -> M Package)
-> CombinedMap
-> EnvConfig
-> [PackageName]
-> Set PackageName
-> Set PackageName
-> Maybe Curator
-> Text
-> Ctx
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 -> EnvConfig -> RIO EnvConfig Package -> M Package
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO EnvConfig
econfig (RIO EnvConfig Package -> M Package)
-> RIO EnvConfig Package -> M Package
forall a b. (a -> b) -> a -> b
$
            Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion (Package -> Package)
-> RIO EnvConfig Package -> RIO EnvConfig Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
loadPackage0 PackageLocationImmutable
w Map FlagName Bool
x [Text]
y [Text]
z
        , combinedMap :: 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 = Map PackageName Target -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMTargets -> Map PackageName Target
smtTargets (SMTargets -> Map PackageName Target)
-> SMTargets -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
        , localNames :: Set PackageName
localNames = Map PackageName ProjectPackage -> Set PackageName
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 = ((GlobalPackage -> Maybe [PackageName])
 -> Map PackageName GlobalPackage -> Map PackageName [PackageName])
-> Map PackageName GlobalPackage
-> (GlobalPackage -> Maybe [PackageName])
-> Map PackageName [PackageName]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GlobalPackage -> Maybe [PackageName])
-> Map PackageName GlobalPackage -> Map PackageName [PackageName]
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap) ((GlobalPackage -> Maybe [PackageName])
 -> Map PackageName [PackageName])
-> (GlobalPackage -> Maybe [PackageName])
-> Map PackageName [PackageName]
forall a b. (a -> b) -> a -> b
$ \GlobalPackage
gp ->
      case GlobalPackage
gp of
         ReplacedGlobalPackage [PackageName]
deps ->
           let pruned :: [PackageName]
pruned = (PackageName -> Bool) -> [PackageName] -> [PackageName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PackageName -> Bool) -> PackageName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
inSourceMap) [PackageName]
deps
           in if [PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
pruned then Maybe [PackageName]
forall a. Maybe a
Nothing else [PackageName] -> Maybe [PackageName]
forall a. a -> Maybe a
Just [PackageName]
pruned
         GlobalPackage Version
_ -> Maybe [PackageName]
forall a. Maybe a
Nothing

    inSourceMap :: PackageName -> Bool
inSourceMap PackageName
pname = PackageName
pname PackageName -> Map PackageName DepPackage -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap Bool -> Bool -> Bool
||
                        PackageName
pname PackageName -> Map PackageName ProjectPackage -> Bool
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 <- ProjectPackage -> RIO env LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage ProjectPackage
pp
            LocalPackage -> RIO env LocalPackage
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
lp { lpPackage :: Package
lpPackage = Version -> Package -> Package
applyForceCustomBuild Version
globalCabalVersion (Package -> Package) -> Package -> Package
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp }
      Map PackageName PackageSource
pPackages <- Map PackageName ProjectPackage
-> (ProjectPackage -> RIO s PackageSource)
-> RIO s (Map PackageName PackageSource)
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) ((ProjectPackage -> RIO s PackageSource)
 -> RIO s (Map PackageName PackageSource))
-> (ProjectPackage -> RIO s PackageSource)
-> RIO s (Map PackageName PackageSource)
forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
        LocalPackage
lp <- ProjectPackage -> RIO s LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
        PackageSource -> RIO s PackageSource
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageSource -> RIO s PackageSource)
-> PackageSource -> RIO s PackageSource
forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
      BuildOpts
bopts <- Getting BuildOpts s BuildOpts -> RIO s BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting BuildOpts s BuildOpts -> RIO s BuildOpts)
-> Getting BuildOpts s BuildOpts -> RIO s BuildOpts
forall a b. (a -> b) -> a -> b
$ (Config -> Const BuildOpts Config) -> s -> Const BuildOpts s
forall env. HasConfig env => Lens' env Config
configL((Config -> Const BuildOpts Config) -> s -> Const BuildOpts s)
-> ((BuildOpts -> Const BuildOpts BuildOpts)
    -> Config -> Const BuildOpts Config)
-> Getting BuildOpts s BuildOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> BuildOpts) -> SimpleGetter Config BuildOpts
forall s a. (s -> a) -> SimpleGetter s a
to Config -> BuildOpts
configBuild
      Map PackageName PackageSource
deps <- Map PackageName DepPackage
-> (DepPackage -> RIO s PackageSource)
-> RIO s (Map PackageName PackageSource)
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) ((DepPackage -> RIO s PackageSource)
 -> RIO s (Map PackageName PackageSource))
-> (DepPackage -> RIO s PackageSource)
-> RIO s (Map PackageName PackageSource)
forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
        case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
          PLImmutable PackageLocationImmutable
loc ->
            PackageSource -> RIO s PackageSource
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageSource -> RIO s PackageSource)
-> PackageSource -> RIO s PackageSource
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 <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO s ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
dir (BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts)
            LocalPackage
lp <- ProjectPackage -> RIO s LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage' ProjectPackage
pp
            PackageSource -> RIO s PackageSource
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageSource -> RIO s PackageSource)
-> PackageSource -> RIO s PackageSource
forall a b. (a -> b) -> a -> b
$ LocalPackage -> PackageSource
PSFilePath LocalPackage
lp
      Map PackageName PackageSource
-> RIO s (Map PackageName PackageSource)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName PackageSource
 -> RIO s (Map PackageName PackageSource))
-> Map PackageName PackageSource
-> RIO s (Map PackageName PackageSource)
forall a b. (a -> b) -> a -> b
$ Map PackageName PackageSource
pPackages Map PackageName PackageSource
-> Map PackageName PackageSource -> Map PackageName PackageSource
forall a. Semigroup a => a -> a -> a
<> Map PackageName PackageSource
deps

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

data NotOnlyLocal = NotOnlyLocal [PackageName] [Text]

instance Show NotOnlyLocal where
  show :: NotOnlyLocal -> String
show (NotOnlyLocal [PackageName]
packages [Text]
exes) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Specified only-locals, but I need to build snapshot contents:\n"
    , if [PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
packages then String
"" else [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Packages: "
        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
packages)
        , String
"\n"
        ]
    , if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
exes then String
"" else [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Executables: "
        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
exes)
        , String
"\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 Map GhcPkgId (PackageIdentifier, Text)
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 = State UnregisterState () -> UnregisterState -> UnregisterState
forall s a. State s a -> s -> s
execState ((DumpPackage -> State UnregisterState ())
-> [DumpPackage] -> State UnregisterState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DumpPackage -> State UnregisterState ()
forall (m :: * -> *).
MonadState UnregisterState m =>
DumpPackage -> m ()
go [DumpPackage]
keep) UnregisterState :: Map GhcPkgId (PackageIdentifier, Text)
-> [DumpPackage] -> Bool -> UnregisterState
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 <- m UnregisterState
forall s (m :: * -> *). MonadState s m => m s
get
        case Map GhcPkgId (PackageIdentifier, Text)
-> PackageIdentifier -> [GhcPkgId] -> Maybe Text
forall k b.
Ord k =>
Map k (PackageIdentifier, b)
-> PackageIdentifier -> [k] -> 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 -> UnregisterState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us { usKeep :: [DumpPackage]
usKeep = DumpPackage
dp DumpPackage -> [DumpPackage] -> [DumpPackage]
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 -> UnregisterState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put UnregisterState
us
                { usToUnregister :: Map GhcPkgId (PackageIdentifier, Text)
usToUnregister = GhcPkgId
-> (PackageIdentifier, Text)
-> Map GhcPkgId (PackageIdentifier, Text)
-> Map GhcPkgId (PackageIdentifier, Text)
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 k (PackageIdentifier, b)
-> PackageIdentifier -> [k] -> Maybe Text
go' Map k (PackageIdentifier, b)
toUnregister PackageIdentifier
ident [k]
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 <- PackageName -> Map PackageName Task -> Maybe 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 PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
ident
              then Maybe Text
forall a. Maybe a
Nothing
              else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> Map PackageName Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Text
dirtyReason
      -- Check if a dependency is going to be unregistered
      | (PackageIdentifier
dep, b
_):[(PackageIdentifier, b)]
_ <- (k -> Maybe (PackageIdentifier, b))
-> [k] -> [(PackageIdentifier, b)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (k -> Map k (PackageIdentifier, b) -> Maybe (PackageIdentifier, b)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k (PackageIdentifier, b)
toUnregister) [k]
deps
          = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Dependency being unregistered: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (PackageIdentifier -> String
packageIdentifierString PackageIdentifier
dep)
      -- None of the above, keep it!
      | Bool
otherwise = Maybe Text
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 -> Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException Task
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException Task))
-> Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException Task
forall a b. a -> Either a b
Left ConstructPlanException
e
        Right (Set PackageIdentifier
missing, Map PackageIdentifier GhcPkgId
present, IsMutable
_minLoc) -> do
            Ctx
ctx <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
            Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException Task
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException Task))
-> Either ConstructPlanException Task
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException Task)
forall a b. (a -> b) -> a -> b
$ Task -> Either ConstructPlanException Task
forall a b. b -> Either a b
Right Task :: PackageIdentifier
-> TaskType
-> TaskConfigOpts
-> Bool
-> Map PackageIdentifier GhcPkgId
-> Bool
-> CachePkgSrc
-> Bool
-> Bool
-> Task
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 ((Map PackageIdentifier GhcPkgId -> ConfigureOpts)
 -> TaskConfigOpts)
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
                    let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = Map PackageIdentifier GhcPkgId
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
present Map PackageIdentifier GhcPkgId
missing'
                     in EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
                            (Getting EnvConfig Ctx EnvConfig -> Ctx -> EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig Ctx EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
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 = String -> CachePkgSrc
CacheSrcLocal (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)))
                , taskAnyMissing :: Bool
taskAnyMissing = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
                , taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Package -> Bool
packageBuildTypeConfig Package
package
                }
    W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wFinals :: Map PackageName (Either ConstructPlanException Task)
wFinals = PackageName
-> Either ConstructPlanException Task
-> Map PackageName (Either ConstructPlanException Task)
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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
addDep PackageName
name = do
    Ctx
ctx <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Map PackageName (Either ConstructPlanException AddDepRes)
m <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Map PackageName (Either ConstructPlanException AddDepRes))
forall s (m :: * -> *). MonadState s m => m s
get
    case PackageName
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> Maybe (Either ConstructPlanException AddDepRes)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Either ConstructPlanException AddDepRes)
m of
        Just Either ConstructPlanException AddDepRes
res -> do
            String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"addDep: Using cached result for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either ConstructPlanException AddDepRes -> String
forall a. Show a => a -> String
show Either ConstructPlanException AddDepRes
res
            Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
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 PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Ctx -> [PackageName]
callStack Ctx
ctx
                then do
                    String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"addDep: Detected cycle " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [PackageName] -> String
forall a. Show a => a -> String
show (Ctx -> [PackageName]
callStack Ctx
ctx)
                    Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException AddDepRes
forall a b. a -> Either a b
Left (ConstructPlanException -> Either ConstructPlanException AddDepRes)
-> ConstructPlanException
-> Either ConstructPlanException AddDepRes
forall a b. (a -> b) -> a -> b
$ [PackageName] -> ConstructPlanException
DependencyCycleDetected ([PackageName] -> ConstructPlanException)
-> [PackageName] -> ConstructPlanException
forall a b. (a -> b) -> a -> b
$ PackageName
name PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx
                else (Ctx -> Ctx)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Ctx
ctx' -> Ctx
ctx' { callStack :: [PackageName]
callStack = PackageName
name PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
: Ctx -> [PackageName]
callStack Ctx
ctx' }) (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   (Either ConstructPlanException AddDepRes)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ do
                    let mpackageInfo :: Maybe PackageInfo
mpackageInfo = PackageName -> CombinedMap -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (CombinedMap -> Maybe PackageInfo)
-> CombinedMap -> Maybe PackageInfo
forall a b. (a -> b) -> a -> b
$ Ctx -> CombinedMap
combinedMap Ctx
ctx
                    String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"addDep: Package info for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe PackageInfo -> String
forall a. Show a => a -> String
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 -> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException AddDepRes
forall a b. a -> Either a b
Left (ConstructPlanException -> Either ConstructPlanException AddDepRes)
-> ConstructPlanException
-> Either ConstructPlanException AddDepRes
forall a b. (a -> b) -> a -> b
$ PackageName -> ConstructPlanException
UnknownPackage PackageName
name
                        Just (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 = RIO Ctx (Maybe PackageLocationImmutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m) =>
RIO env a -> m a
liftRIO (RIO Ctx (Maybe PackageLocationImmutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe PackageLocationImmutable))
-> RIO Ctx (Maybe PackageLocationImmutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ do
                                  Maybe (Revision, BlobKey, TreeKey)
mrev <- RequireHackageIndex
-> PackageName
-> Version
-> RIO Ctx (Maybe (Revision, BlobKey, TreeKey))
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
                                  case Maybe (Revision, BlobKey, TreeKey)
mrev of
                                    Maybe (Revision, BlobKey, TreeKey)
Nothing -> do
                                      -- this could happen for GHC boot libraries missing from Hackage
                                      Utf8Builder -> RIO Ctx ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO Ctx ()) -> Utf8Builder -> RIO Ctx ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No latest package revision found for: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                          String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
name) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", dependency callstack: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                                          [String] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Ctx -> [PackageName]
callStack Ctx
ctx)
                                      Maybe PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
                                    Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) ->
                                      Maybe PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageLocationImmutable
 -> RIO Ctx (Maybe PackageLocationImmutable))
-> (PackageLocationImmutable -> Maybe PackageLocationImmutable)
-> PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (PackageLocationImmutable
 -> RIO Ctx (Maybe PackageLocationImmutable))
-> PackageLocationImmutable
-> RIO Ctx (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$
                                          PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
                            PackageName
-> 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 Map FlagName Bool
forall k a. Map k a
Map.empty
                            Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. b -> Either a b
Right (AddDepRes -> Either ConstructPlanException AddDepRes)
-> AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. (a -> b) -> a -> b
$ InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
                        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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps (Installed -> Maybe Installed
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
            Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
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 (Package
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> Package
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
    | Bool
otherwise = ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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
_fromSnaphot 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 (Maybe PackageLocationImmutable
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Maybe PackageLocationImmutable
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Ctx -> Set PackageName
wanted Ctx
ctx) (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   ()
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe PackageLocationImmutable
mPkgLoc <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Maybe PackageLocationImmutable)
retrievePkgLoc
        Maybe PackageLocationImmutable
-> (PackageLocationImmutable
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PackageLocationImmutable
mPkgLoc ((PackageLocationImmutable
  -> RWST
       Ctx
       W
       (Map PackageName (Either ConstructPlanException AddDepRes))
       IO
       ())
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> (PackageLocationImmutable
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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 <- (Ctx -> CombinedMap)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     CombinedMap
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 PackageName -> CombinedMap -> Maybe PackageInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Package -> PackageName
packageName Package
p) CombinedMap
cm of
                Maybe PackageInfo
Nothing -> Bool -> Set Text -> Set Text
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Set Text
forall a. Set a
Set.empty
                Just (PIOnlyInstalled InstallLocation
_ Installed
_) -> Set Text
forall a. Set a
Set.empty
                Just (PIOnlySource PackageSource
ps) -> PackageSource -> Set Text
goSource PackageSource
ps
                Just (PIBoth PackageSource
ps Installed
_) -> PackageSource -> Set Text
goSource PackageSource
ps

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

    W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wInstall :: Map Text InstallLocation
wInstall = [(Text, InstallLocation)] -> Map Text InstallLocation
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, InstallLocation)] -> Map Text InstallLocation)
-> [(Text, InstallLocation)] -> Map Text InstallLocation
forall a b. (a -> b) -> a -> b
$ (Text -> (Text, InstallLocation))
-> [Text] -> [(Text, InstallLocation)]
forall a b. (a -> b) -> [a] -> [b]
map (, InstallLocation
loc) ([Text] -> [(Text, InstallLocation)])
-> [Text] -> [(Text, InstallLocation)]
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
filterComps Set Text
myComps (Set Text -> Set Text) -> Set Text -> Set Text
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
        | Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
myComps = Set a
x
        | Bool
otherwise = Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
x Set a
myComps

-- | Given a 'PackageSource' and perhaps an 'Installed' value, adds
-- build 'Task's for the package and its dependencies.
installPackage :: PackageName
               -> PackageSource
               -> Maybe Installed
               -> M (Either ConstructPlanException AddDepRes)
installPackage :: PackageName
-> PackageSource
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
installPackage PackageName
name PackageSource
ps Maybe Installed
minstalled = do
    Ctx
ctx <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    case PackageSource
ps of
        PSRemote PackageLocationImmutable
pkgLoc Version
_version FromSnapshot
_fromSnaphot CommonPackage
cp -> do
            String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"installPackage: Doing all-in-one build for upstream package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (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
                    String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"installPackage: No test / bench component for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" so doing an all-in-one build."
                    Bool
-> Bool
-> PackageSource
-> Package
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Map PackageName (Either ConstructPlanException AddDepRes))
forall s (m :: * -> *). MonadState s m => m s
get
                    Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  (Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
   W -> W)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   (Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
    W -> W)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
      W -> W)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ do
                        Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
tb
                        let writerFunc :: p -> p
writerFunc p
w = case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
                                Left ConstructPlanException
_ -> p
forall a. Monoid a => a
mempty
                                Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
_ -> p
w
                        (Either
   ConstructPlanException
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
 W -> W)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable),
      W -> W)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res, W -> W
forall p. Monoid p => p -> p
writerFunc)
                    case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
                        Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps -> do
                          String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"installPackage: For " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Show a => a -> String
show PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", 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 (Maybe Curator -> Bool)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Curator)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ctx -> Maybe Curator)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Curator)
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
                          Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. b -> Either a b
Right AddDepRes
adr
                        Left ConstructPlanException
_ -> do
                            -- Reset the state to how it was before
                            -- attempting to find an all-in-one build
                            -- plan.
                            String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadIO m => String -> m ()
planDebug (String
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> String
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ String
"installPackage: Before trying cyclic plan, resetting lib result map to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map PackageName (Either ConstructPlanException AddDepRes) -> String
forall a. Show a => a -> String
show Map PackageName (Either ConstructPlanException AddDepRes)
s
                            Map PackageName (Either ConstructPlanException AddDepRes)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
False (LocalPackage -> Bool
lpBuildHaddocks LocalPackage
lp) PackageSource
ps (LocalPackage -> Package
lpPackage LocalPackage
lp) Maybe Installed
minstalled
                            Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either ConstructPlanException AddDepRes -> Bool
forall a b. Either a b -> Bool
isRight Either ConstructPlanException AddDepRes
res') (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   ()
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
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
                            Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ConstructPlanException AddDepRes
res'
 where
   expectedTestOrBenchFailures :: Maybe Curator -> Bool
expectedTestOrBenchFailures Maybe Curator
maybeCurator = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
     Curator
curator <- Maybe Curator
maybeCurator
     Bool -> Maybe Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name (Curator -> Set PackageName
curatorExpectTestFailure Curator
curator) Bool -> Bool -> Bool
||
            PackageName -> Set PackageName -> 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
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
resolveDepsAndInstall Bool
isAllInOne Bool
buildHaddocks PackageSource
ps Package
package Maybe Installed
minstalled = do
    Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res <- Package
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
addPackageDeps Package
package
    case Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
res of
        Left ConstructPlanException
err -> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConstructPlanException AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> Either ConstructPlanException AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall a b. (a -> b) -> a -> b
$ ConstructPlanException -> Either ConstructPlanException AddDepRes
forall a b. a -> Either a b
Left ConstructPlanException
err
        Right (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
deps -> (AddDepRes -> Either ConstructPlanException AddDepRes)
-> M AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM AddDepRes -> Either ConstructPlanException AddDepRes
forall a b. b -> Either a b
Right (M AddDepRes
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ConstructPlanException AddDepRes))
-> M AddDepRes
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ConstructPlanException AddDepRes)
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe Installed
mRightVersionInstalled <- case (Maybe Installed
minstalled, Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing) of
        (Just Installed
installed, Bool
True) -> do
            Bool
shouldInstall <- PackageSource
-> Installed
-> Package
-> Map PackageIdentifier GhcPkgId
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
checkDirtiness PackageSource
ps Installed
installed Package
package Map PackageIdentifier GhcPkgId
present Bool
buildHaddocks
            Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Installed
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Installed))
-> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall a b. (a -> b) -> a -> b
$ if Bool
shouldInstall then Maybe Installed
forall a. Maybe a
Nothing else Installed -> Maybe Installed
forall a. a -> Maybe a
Just Installed
installed
        (Just Installed
_, Bool
False) -> do
            let t :: Text
t = Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (PackageIdentifier -> Text) -> [PackageIdentifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text)
-> (PackageIdentifier -> String) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> String)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName) (Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing)
            W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wDirty :: Map PackageName Text
wDirty = PackageName -> Text -> Map PackageName Text
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (Text -> Map PackageName Text) -> Text -> Map PackageName Text
forall a b. (a -> b) -> a -> b
$ Text
"missing dependencies: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis Text
t }
            Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Installed
forall a. Maybe a
Nothing
        (Maybe Installed
Nothing, Bool
_) -> Maybe Installed
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Installed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Installed
forall a. Maybe a
Nothing
    let loc :: InstallLocation
loc = PackageSource -> InstallLocation
psLocation PackageSource
ps
        mutable :: IsMutable
mutable = InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc IsMutable -> IsMutable -> IsMutable
forall a. Semigroup a => a -> a -> a
<> IsMutable
minMutable
    AddDepRes -> M AddDepRes
forall (m :: * -> *) a. Monad m => a -> m a
return (AddDepRes -> M AddDepRes) -> AddDepRes -> M AddDepRes
forall a b. (a -> b) -> a -> b
$ case Maybe Installed
mRightVersionInstalled of
        Just Installed
installed -> InstallLocation -> Installed -> AddDepRes
ADRFound InstallLocation
loc Installed
installed
        Maybe Installed
Nothing -> Task -> AddDepRes
ADRToInstall Task :: PackageIdentifier
-> TaskType
-> TaskConfigOpts
-> Bool
-> Map PackageIdentifier GhcPkgId
-> Bool
-> CachePkgSrc
-> Bool
-> Bool
-> Task
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 ((Map PackageIdentifier GhcPkgId -> ConfigureOpts)
 -> TaskConfigOpts)
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
forall a b. (a -> b) -> a -> b
$ \Map PackageIdentifier GhcPkgId
missing' ->
                let allDeps :: Map PackageIdentifier GhcPkgId
allDeps = Map PackageIdentifier GhcPkgId
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
present Map PackageIdentifier GhcPkgId
missing'
                 in EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
                        (Getting EnvConfig Ctx EnvConfig -> Ctx -> EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig Ctx EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
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
_fromSnaphot 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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> Bool
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 BuildType -> BuildType -> Bool
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 = (Map PackageName (Either ConstructPlanException AddDepRes)
 -> Map PackageName (Either ConstructPlanException AddDepRes))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map PackageName (Either ConstructPlanException AddDepRes)
  -> Map PackageName (Either ConstructPlanException AddDepRes))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ())
-> (Map PackageName (Either ConstructPlanException AddDepRes)
    -> Map PackageName (Either ConstructPlanException AddDepRes))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall a b. (a -> b) -> a -> b
$ \Map PackageName (Either ConstructPlanException AddDepRes)
mp ->
    case (PackageName
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> Maybe (Either ConstructPlanException AddDepRes)
forall k a. Ord k => k -> Map k a -> Maybe a
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)
_ -> PackageName
-> Either ConstructPlanException AddDepRes
-> Map PackageName (Either ConstructPlanException AddDepRes)
-> Map PackageName (Either ConstructPlanException AddDepRes)
forall k a. Ord k => k -> a -> Map k a -> Map k a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100 = Text
t
    | Bool
otherwise = Int -> Text -> Text
T.take Int
97 Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."

-- | Given a package, recurses into all of its dependencies. The 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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  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 <- [(PackageName, DepValue)]
-> ((PackageName, DepValue)
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Either
            (PackageName,
             (VersionRange, Maybe (Version, BlobKey), BadDependency))
            (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
             IsMutable)))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PackageName DepValue -> [(PackageName, DepValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName DepValue
deps') (((PackageName, DepValue)
  -> RWST
       Ctx
       W
       (Map PackageName (Either ConstructPlanException AddDepRes))
       IO
       (Either
          (PackageName,
           (VersionRange, Maybe (Version, BlobKey), BadDependency))
          (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
           IsMutable)))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      [Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)])
-> ((PackageName, DepValue)
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Either
            (PackageName,
             (VersionRange, Maybe (Version, BlobKey), BadDependency))
            (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
             IsMutable)))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
forall a b. (a -> b) -> a -> b
$ \(PackageName
depname, DepValue VersionRange
range DepType
depType) -> do
        Either ConstructPlanException AddDepRes
eres <- PackageName
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (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 <- Ctx
-> RIO Ctx (Map Version (Map Revision BlobKey))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Map Version (Map Revision BlobKey))
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx (RIO Ctx (Map Version (Map Revision BlobKey))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Map Version (Map Revision BlobKey)))
-> RIO Ctx (Map Version (Map Revision BlobKey))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Map Version (Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO Ctx (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
YesRequireHackageIndex UsePreferredVersions
UsePreferredVersions PackageName
depname
              Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey)))
-> Maybe (Version, BlobKey) -> M (Maybe (Version, BlobKey))
forall a b. (a -> b) -> a -> b
$ do
                Version
lappVer <- VersionRange -> Set Version -> Maybe Version
latestApplicableVersion VersionRange
range (Set Version -> Maybe Version) -> Set Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Map Version (Map Revision BlobKey) -> Set Version
forall k a. Map k a -> Set k
Map.keysSet Map Version (Map Revision BlobKey)
vsAndRevs
                Map Revision BlobKey
revs <- Version
-> Map Version (Map Revision BlobKey)
-> Maybe (Map Revision BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Version
lappVer Map Version (Map Revision BlobKey)
vsAndRevs
                (BlobKey
cabalHash, Map Revision BlobKey
_) <- Map Revision BlobKey -> Maybe (BlobKey, Map Revision BlobKey)
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map Revision BlobKey
revs
                (Version, BlobKey) -> Maybe (Version, BlobKey)
forall a. a -> Maybe a
Just (Version
lappVer, BlobKey
cabalHash)
        case Either ConstructPlanException AddDepRes
eres of
            Left ConstructPlanException
e -> do
                PackageName
-> VersionRange
-> Maybe Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *).
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range Maybe Version
forall a. Maybe a
Nothing
                let bd :: BadDependency
bd =
                        case ConstructPlanException
e of
                            UnknownPackage PackageName
name -> Bool -> BadDependency -> BadDependency
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageName
name PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
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
                Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
mlatestApplicable, BadDependency
bd))
            Right AddDepRes
adr | DepType
depType DepType -> DepType -> Bool
forall a. Eq a => a -> a -> Bool
== DepType
AsLibrary Bool -> Bool -> Bool
&& Bool -> Bool
not (AddDepRes -> Bool
adrHasLibrary AddDepRes
adr) ->
                Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
forall a. Maybe a
Nothing, BadDependency
HasNoLibrary))
            Right AddDepRes
adr -> do
                PackageName
-> VersionRange
-> Maybe Version
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *).
MonadWriter W m =>
PackageName -> VersionRange -> Maybe Version -> m ()
addParent PackageName
depname VersionRange
range Maybe Version
forall a. Maybe a
Nothing
                Bool
inRange <- if AddDepRes -> Version
adrVersion AddDepRes
adr Version -> VersionRange -> Bool
`withinRange` VersionRange
range
                    then Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    else do
                        let warn_ :: Text -> m ()
warn_ Text
reason =
                                W -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = (Text
msgText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) }
                              where
                                msg :: Text
msg = [Text] -> Text
T.concat
                                    [ Text
"WARNING: Ignoring "
                                    , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
                                    , Text
"'s bounds on "
                                    , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
depname
                                    , Text
" ("
                                    , VersionRange -> Text
versionRangeText VersionRange
range
                                    , Text
"); using "
                                    , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> String) -> PackageIdentifier -> String
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 <- Getting Bool Ctx Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool Ctx Bool
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      Bool)
-> Getting Bool Ctx Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> Ctx -> Const Bool Ctx
forall env. HasConfig env => Lens' env Config
configL((Config -> Const Bool Config) -> Ctx -> Const Bool Ctx)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool Ctx Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
                        if Bool
allowNewer
                            then do
                                Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadWriter W m => Text -> m ()
warn_ Text
"allow-newer enabled"
                                Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
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
                                        Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall (m :: * -> *). MonadWriter W m => Text -> m ()
warn_ Text
"trusting snapshot over cabal file dependency information"
                                        Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                    else Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                if Bool
inRange
                    then case AddDepRes
adr of
                        ADRToInstall Task
task -> Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right
                            (PackageIdentifier -> Set PackageIdentifier
forall a. a -> Set a
Set.singleton (PackageIdentifier -> Set PackageIdentifier)
-> PackageIdentifier -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task, Map PackageIdentifier GhcPkgId
forall k a. Map k a
Map.empty, Task -> IsMutable
taskTargetIsMutable Task
task)
                        ADRFound InstallLocation
loc (Executable PackageIdentifier
_) -> Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right
                            (Set PackageIdentifier
forall a. Set a
Set.empty, Map PackageIdentifier GhcPkgId
forall k a. Map k a
Map.empty, InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
loc)
                        ADRFound InstallLocation
loc (Library PackageIdentifier
ident GhcPkgId
gid Maybe (Either License License)
_) -> Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right
                            (Set PackageIdentifier
forall a. Set a
Set.empty, PackageIdentifier -> GhcPkgId -> Map PackageIdentifier GhcPkgId
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
                        Either
  (PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either
         (PackageName,
          (VersionRange, Maybe (Version, BlobKey), BadDependency))
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either
        (PackageName,
         (VersionRange, Maybe (Version, BlobKey), BadDependency))
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Either
     (PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (PackageName
depname, (VersionRange
range, Maybe (Version, BlobKey)
mlatestApplicable, Version -> BadDependency
DependencyMismatch (Version -> BadDependency) -> Version -> BadDependency
forall a b. (a -> b) -> a -> b
$ AddDepRes -> Version
adrVersion AddDepRes
adr))
    case [Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
-> ([(PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))],
    [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
      IsMutable)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (PackageName,
    (VersionRange, Maybe (Version, BlobKey), BadDependency))
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)]
deps of
        -- Note that the Monoid for '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) -> Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ConstructPlanException
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. b -> Either a b
Right ((Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. (a -> b) -> a -> b
$ [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
-> (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
    IsMutable)
forall a. Monoid a => [a] -> a
mconcat [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
pairs
        ([(PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))]
errs, [(Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
  IsMutable)]
_) -> Either
  ConstructPlanException
  (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ConstructPlanException
   (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
 -> M (Either
         ConstructPlanException
         (Set PackageIdentifier, Map PackageIdentifier GhcPkgId,
          IsMutable)))
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
-> M (Either
        ConstructPlanException
        (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
forall a b. (a -> b) -> a -> b
$ ConstructPlanException
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. a -> Either a b
Left (ConstructPlanException
 -> Either
      ConstructPlanException
      (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))
-> ConstructPlanException
-> Either
     ConstructPlanException
     (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable)
forall a b. (a -> b) -> a -> b
$ Package
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> ConstructPlanException
DependencyPlanFailures
            Package
package
            ([(PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))]
errs)
  where
    adrVersion :: AddDepRes -> Version
adrVersion (ADRToInstall Task
task) = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
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 = W -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wParents :: ParentMap
wParents = Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> ParentMap
forall k a. Map k a -> MonoidMap k a
MonoidMap (Map
   PackageName (First Version, [(PackageIdentifier, VersionRange)])
 -> ParentMap)
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> ParentMap
forall a b. (a -> b) -> a -> b
$ PackageName
-> (First Version, [(PackageIdentifier, VersionRange)])
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
forall k a. k -> a -> Map k a
M.singleton PackageName
depname (First Version, [(PackageIdentifier, VersionRange)])
val }
      where
        val :: (First Version, [(PackageIdentifier, VersionRange)])
val = (Maybe Version -> First Version
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 (Package -> Bool) -> Package -> Bool
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 (Set Text -> Bool
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe ConfigCache
moldOpts <- Ctx
-> RIO Ctx (Maybe ConfigCache)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ConfigCache)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Ctx
ctx (RIO Ctx (Maybe ConfigCache)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe ConfigCache))
-> RIO Ctx (Maybe ConfigCache)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ Installed -> RIO Ctx (Maybe ConfigCache)
forall env.
HasEnvConfig env =>
Installed -> RIO env (Maybe ConfigCache)
tryGetFlagCache Installed
installed
    let configOpts :: ConfigureOpts
configOpts = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts
            (Getting EnvConfig Ctx EnvConfig -> Ctx -> EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig Ctx EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL Ctx
ctx)
            (Ctx -> BaseConfigOpts
baseConfigOpts Ctx
ctx)
            Map PackageIdentifier GhcPkgId
present
            (PackageSource -> Bool
psLocal PackageSource
ps)
            (InstallLocation -> IsMutable
installLocationIsMutable (InstallLocation -> IsMutable) -> InstallLocation -> IsMutable
forall a b. (a -> b) -> a -> b
$ PackageSource -> InstallLocation
psLocation PackageSource
ps) -- should be Local i.e. mutable always
            Package
package
        wantConfigCache :: ConfigCache
wantConfigCache = ConfigCache :: ConfigureOpts
-> Set GhcPkgId
-> Set ByteString
-> Bool
-> CachePkgSrc
-> Text
-> ConfigCache
ConfigCache
            { configCacheOpts :: ConfigureOpts
configCacheOpts = ConfigureOpts
configOpts
            , configCacheDeps :: Set GhcPkgId
configCacheDeps = [GhcPkgId] -> Set GhcPkgId
forall a. Ord a => [a] -> Set a
Set.fromList ([GhcPkgId] -> Set GhcPkgId) -> [GhcPkgId] -> Set GhcPkgId
forall a b. (a -> b) -> a -> b
$ Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
present
            , configCacheComponents :: Set ByteString
configCacheComponents =
                case PackageSource
ps of
                    PSFilePath LocalPackage
lp -> (NamedComponent -> ByteString)
-> Set NamedComponent -> Set ByteString
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (NamedComponent -> Text) -> NamedComponent -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) (Set NamedComponent -> Set ByteString)
-> Set NamedComponent -> Set ByteString
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
                    PSRemote{} -> Set ByteString
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 = Getting Config Ctx Config -> Ctx -> Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config Ctx Config
forall env. HasConfig env => Lens' env Config
configL Ctx
ctx
    Maybe Text
mreason <-
      case Maybe ConfigCache
moldOpts of
        Maybe ConfigCache
Nothing -> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"old configure information not found"
        Just ConfigCache
oldOpts
          | Just Text
reason <- Config -> ConfigCache -> ConfigCache -> Maybe Text
describeConfigDiff Config
config ConfigCache
oldOpts ConfigCache
wantConfigCache -> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason
          | Bool
True <- PackageSource -> Bool
psForceDirty PackageSource
ps -> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"--force-dirty specified"
          | Bool
otherwise -> do
              Maybe (Set String)
dirty <- PackageSource
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe (Set String))
forall (m :: * -> *) env.
(MonadIO m, HasEnvConfig env, MonadReader env m) =>
PackageSource -> m (Maybe (Set String))
psDirty PackageSource
ps
              Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe Text))
-> Maybe Text
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$
                case Maybe (Set String)
dirty of
                  Just Set String
files -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"local file changes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
addEllipsis (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
files)
                  Maybe (Set String)
Nothing -> Maybe Text
forall a. Maybe a
Nothing
    case Maybe Text
mreason of
        Maybe Text
Nothing -> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just Text
reason -> do
            W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wDirty :: Map PackageName Text
wDirty = PackageName -> Text -> Map PackageName Text
forall k a. k -> a -> Map k a
Map.singleton (Package -> PackageName
packageName Package
package) Text
reason }
            Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
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 CachePkgSrc -> CachePkgSrc -> Bool
forall a. Eq a => a -> a -> Bool
/= ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
        Text
"switching from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        CachePkgSrc -> Text
pkgSrcName (ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
old) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        CachePkgSrc -> Text
pkgSrcName (ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new)
    | Bool -> Bool
not (ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
new Set GhcPkgId -> Set GhcPkgId -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
old) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dependencies changed"
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set ByteString -> Bool
forall a. Set a -> Bool
Set.null Set ByteString
newComponents =
        Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"components added: " Text -> Text -> Text
`T.append` Text -> [Text] -> Text
T.intercalate Text
", "
            ((ByteString -> Text) -> [ByteString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) (Set ByteString -> [ByteString]
forall a. Set a -> [a]
Set.toList Set ByteString
newComponents))
    | Bool -> Bool
not (ConfigCache -> Bool
configCacheHaddock ConfigCache
old) Bool -> Bool -> Bool
&& ConfigCache -> Bool
configCacheHaddock ConfigCache
new = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rebuilding with haddocks"
    | [Text]
oldOpts [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text]
newOpts = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"flags changed from "
        , [Text] -> String
forall a. Show a => a -> String
show [Text]
oldOpts
        , String
" to "
        , [Text] -> String
forall a. Show a => a -> String
show [Text]
newOpts
        ]
    | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
  where
    stripGhcOptions :: [Text] -> [Text]
stripGhcOptions =
        [Text] -> [Text]
go
      where
        go :: [Text] -> [Text]
go [] = []
        go (Text
"--ghc-option":Text
x:[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
        go (Text
"--ghc-options":Text
x:[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
        go ((Text -> Text -> Maybe Text
T.stripPrefix Text
"--ghc-option=" -> Just Text
x):[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
        go ((Text -> Text -> Maybe Text
T.stripPrefix Text
"--ghc-options=" -> Just Text
x):[Text]
xs) = WhichCompiler -> Text -> [Text] -> [Text]
go' WhichCompiler
Ghc Text
x [Text]
xs
        go (Text
x:[Text]
xs) = Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go [Text]
xs

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

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

        -- GHC options which affect build results and therefore should always
        -- force a rebuild
        --
        -- For the most part, we only care about options generated by Stack
        -- itself
        isKeeper :: Text -> Bool
isKeeper = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-fhpc") -- more to be added later

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

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

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

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

    pkgSrcName :: CachePkgSrc -> Text
pkgSrcName (CacheSrcLocal String
fp) = String -> Text
T.pack String
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 :: PackageSource -> m (Maybe (Set String))
psDirty (PSFilePath LocalPackage
lp) = MemoizedWith EnvConfig (Maybe (Set String))
-> m (Maybe (Set String))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith (MemoizedWith EnvConfig (Maybe (Set String))
 -> m (Maybe (Set String)))
-> MemoizedWith EnvConfig (Maybe (Set String))
-> m (Maybe (Set String))
forall a b. (a -> b) -> a -> b
$ LocalPackage -> MemoizedWith EnvConfig (Maybe (Set String))
lpDirtyFiles LocalPackage
lp
psDirty PSRemote {} = Maybe (Set String) -> m (Maybe (Set String))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set String)
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 <- ([Maybe ToolWarning] -> [ToolWarning])
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [ToolWarning]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ToolWarning] -> [ToolWarning]
forall a. [Maybe a] -> [a]
catMaybes (RWST
   Ctx
   W
   (Map PackageName (Either ConstructPlanException AddDepRes))
   IO
   [Maybe ToolWarning]
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      [ToolWarning])
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [ToolWarning]
forall a b. (a -> b) -> a -> b
$ [ExeName]
-> (ExeName
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Maybe ToolWarning))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set ExeName -> [ExeName]
forall a. Set a -> [a]
Set.toList (Set ExeName -> [ExeName]) -> Set ExeName -> [ExeName]
forall a b. (a -> b) -> a -> b
$ Package -> Set ExeName
packageUnknownTools Package
p) ((ExeName
  -> RWST
       Ctx
       W
       (Map PackageName (Either ConstructPlanException AddDepRes))
       IO
       (Maybe ToolWarning))
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      [Maybe ToolWarning])
-> (ExeName
    -> RWST
         Ctx
         W
         (Map PackageName (Either ConstructPlanException AddDepRes))
         IO
         (Maybe ToolWarning))
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     [Maybe ToolWarning]
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 <- Getting Config Ctx Config
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config Ctx Config
forall env. HasConfig env => Lens' env Config
configL
        ProcessContext
menv <- IO ProcessContext
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      ProcessContext)
-> IO ProcessContext
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
settings
        Either ProcessException String
mfound <- ProcessContext
-> RIO ProcessContext (Either ProcessException String)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ProcessException String)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ProcessContext
menv (RIO ProcessContext (Either ProcessException String)
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Either ProcessException String))
-> RIO ProcessContext (Either ProcessException String)
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Either ProcessException String)
forall a b. (a -> b) -> a -> b
$ String -> RIO ProcessContext (Either ProcessException String)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable (String -> RIO ProcessContext (Either ProcessException String))
-> String -> RIO ProcessContext (Either ProcessException String)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
toolName
        case Either ProcessException String
mfound of
            Left ProcessException
_ -> Maybe ToolWarning
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ToolWarning)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ToolWarning
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      (Maybe ToolWarning))
-> Maybe ToolWarning
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ToolWarning)
forall a b. (a -> b) -> a -> b
$ ToolWarning -> Maybe ToolWarning
forall a. a -> Maybe a
Just (ToolWarning -> Maybe ToolWarning)
-> ToolWarning -> Maybe ToolWarning
forall a b. (a -> b) -> a -> b
$ ExeName -> PackageName -> ToolWarning
ToolWarning ExeName
name (Package -> PackageName
packageName Package
p)
            Right String
_ -> Maybe ToolWarning
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     (Maybe ToolWarning)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ToolWarning
forall a. Maybe a
Nothing
    W
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell W
forall a. Monoid a => a
mempty { wWarnings :: [Text] -> [Text]
wWarnings = ((ToolWarning -> Text) -> [ToolWarning] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ToolWarning -> Text
toolWarningText [ToolWarning]
warnings [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++) }
    Map PackageName DepValue -> M (Map PackageName DepValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName DepValue -> M (Map PackageName DepValue))
-> Map PackageName DepValue -> M (Map PackageName DepValue)
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 -> String
(Int -> ToolWarning -> ShowS)
-> (ToolWarning -> String)
-> ([ToolWarning] -> ShowS)
-> Show ToolWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ToolWarning] -> ShowS
$cshowList :: [ToolWarning] -> ShowS
show :: ToolWarning -> String
$cshow :: ToolWarning -> String
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
toolName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    Text
" executable, which is a build-tool dependency of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    String -> Text
T.pack (PackageName -> String
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 = (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask (Map PackageName Task -> Map PackageName Task)
-> Map PackageName Task -> Map PackageName Task
forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
    , planFinals :: Map PackageName Task
planFinals = Map PackageName Task
forall k a. Map k a
Map.empty
    , planUnregisterLocal :: Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal = Map GhcPkgId (PackageIdentifier, Text)
forall k a. Map k a
Map.empty
    , planInstallExes :: Map Text InstallLocation
planInstallExes = (InstallLocation -> Bool)
-> Map Text InstallLocation -> Map Text InstallLocation
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
/= InstallLocation
Local) (Map Text InstallLocation -> Map Text InstallLocation)
-> Map Text InstallLocation -> Map Text InstallLocation
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 InstallLocation -> InstallLocation -> Bool
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 = (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
checkTask (Map PackageName Task -> Map PackageName Task)
-> Map PackageName Task -> Map PackageName Task
forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
    , planFinals :: Map PackageName Task
planFinals = Map PackageName Task
forall k a. Map k a
Map.empty
    , planInstallExes :: Map Text InstallLocation
planInstallExes = Map Text InstallLocation
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 PackageIdentifier -> Set PackageIdentifier -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageIdentifier
missingForDeps
    providesDep :: Task -> Bool
providesDep Task
task = PackageIdentifier -> PackageName
pkgName (Task -> PackageIdentifier
taskProvides Task
task) PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
deps
    missing :: Map PackageIdentifier (Set PackageIdentifier)
missing = [(PackageIdentifier, Set PackageIdentifier)]
-> Map PackageIdentifier (Set PackageIdentifier)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageIdentifier, Set PackageIdentifier)]
 -> Map PackageIdentifier (Set PackageIdentifier))
-> [(PackageIdentifier, Set PackageIdentifier)]
-> Map PackageIdentifier (Set PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ (Task -> (PackageIdentifier, Set PackageIdentifier))
-> [Task] -> [(PackageIdentifier, Set PackageIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map (Task -> PackageIdentifier
taskProvides (Task -> PackageIdentifier)
-> (Task -> Set PackageIdentifier)
-> Task
-> (PackageIdentifier, Set PackageIdentifier)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TaskConfigOpts -> Set PackageIdentifier
tcoMissing (TaskConfigOpts -> Set PackageIdentifier)
-> (Task -> TaskConfigOpts) -> Task -> Set PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> TaskConfigOpts
taskConfigOpts) ([Task] -> [(PackageIdentifier, Set PackageIdentifier)])
-> [Task] -> [(PackageIdentifier, Set PackageIdentifier)]
forall a b. (a -> b) -> a -> b
$
              Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Plan -> Map PackageName Task
planTasks Plan
plan)
    missingForDeps :: Set PackageIdentifier
missingForDeps = (State (Set PackageIdentifier) ()
 -> Set PackageIdentifier -> Set PackageIdentifier)
-> Set PackageIdentifier
-> State (Set PackageIdentifier) ()
-> Set PackageIdentifier
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Set PackageIdentifier) ()
-> Set PackageIdentifier -> Set PackageIdentifier
forall s a. State s a -> s -> s
execState Set PackageIdentifier
forall a. Monoid a => a
mempty (State (Set PackageIdentifier) () -> Set PackageIdentifier)
-> State (Set PackageIdentifier) () -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ do
      [Task]
-> (Task -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task]) -> Map PackageName Task -> [Task]
forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan) ((Task -> State (Set PackageIdentifier) ())
 -> State (Set PackageIdentifier) ())
-> (Task -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
forall a b. (a -> b) -> a -> b
$ \Task
task ->
        Bool
-> State (Set PackageIdentifier) ()
-> State (Set PackageIdentifier) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Task -> Bool
providesDep Task
task) (State (Set PackageIdentifier) ()
 -> State (Set PackageIdentifier) ())
-> State (Set PackageIdentifier) ()
-> State (Set PackageIdentifier) ()
forall a b. (a -> b) -> a -> b
$ [PackageIdentifier]
-> PackageIdentifier -> State (Set PackageIdentifier) ()
forall (m :: * -> *).
MonadState (Set PackageIdentifier) m =>
[PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
forall a. Monoid a => a
mempty (Task -> PackageIdentifier
taskProvides Task
task)

    collectMissing :: [PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing [PackageIdentifier]
dependents PackageIdentifier
pid = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
pid PackageIdentifier -> [PackageIdentifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageIdentifier]
dependents) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. (?callStack::CallStack) => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        String
"Unexpected: task cycle for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> String
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pid)
      (Set PackageIdentifier -> Set PackageIdentifier) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify'(Set PackageIdentifier
-> Set PackageIdentifier -> Set PackageIdentifier
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> Set PackageIdentifier
forall a. a -> Set a
Set.singleton PackageIdentifier
pid)
      (PackageIdentifier -> m ()) -> Set PackageIdentifier -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([PackageIdentifier] -> PackageIdentifier -> m ()
collectMissing (PackageIdentifier
pidPackageIdentifier -> [PackageIdentifier] -> [PackageIdentifier]
forall a. a -> [a] -> [a]
:[PackageIdentifier]
dependents)) (Set PackageIdentifier
-> Maybe (Set PackageIdentifier) -> Set PackageIdentifier
forall a. a -> Maybe a -> a
fromMaybe Set PackageIdentifier
forall a. Monoid a => a
mempty (Maybe (Set PackageIdentifier) -> Set PackageIdentifier)
-> Maybe (Set PackageIdentifier) -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> Map PackageIdentifier (Set PackageIdentifier)
-> Maybe (Set PackageIdentifier)
forall k a. Ord k => k -> Map k a -> Maybe a
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 <- RWST
  Ctx
  W
  (Map PackageName (Either ConstructPlanException AddDepRes))
  IO
  Ctx
forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
 -> RWST
      Ctx
      W
      (Map PackageName (Either ConstructPlanException AddDepRes))
      IO
      Bool)
-> Bool
-> RWST
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
     IO
     Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
        PackageInfo
ps <- PackageName -> CombinedMap -> Maybe PackageInfo
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
_) ->
                Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Version
srcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version
            PIBoth (PSRemote PackageLocationImmutable
_ Version
srcVersion FromSnapshot
FromSnapshot CommonPackage
_) Installed
_ ->
                Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Version
srcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version
            -- OnlyInstalled occurs for global database
            PIOnlyInstalled InstallLocation
loc (Library PackageIdentifier
pid GhcPkgId
_gid Maybe (Either License License)
_lic) ->
              Bool -> Maybe Bool -> Maybe Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (InstallLocation
loc InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Snap) (Maybe Bool -> Maybe Bool) -> Maybe Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
              Bool -> Maybe Bool -> Maybe Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pid Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version) (Maybe Bool -> Maybe Bool) -> Maybe Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
              Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            PackageInfo
_ -> Bool -> Maybe Bool
forall (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
(ConstructPlanException -> ConstructPlanException -> Bool)
-> (ConstructPlanException -> ConstructPlanException -> Bool)
-> Eq ConstructPlanException
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 -> String
(Int -> ConstructPlanException -> ShowS)
-> (ConstructPlanException -> String)
-> ([ConstructPlanException] -> ShowS)
-> Show ConstructPlanException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConstructPlanException] -> ShowS
$cshowList :: [ConstructPlanException] -> ShowS
show :: ConstructPlanException -> String
$cshow :: ConstructPlanException -> String
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
(BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool) -> Eq BadDependency
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
Eq BadDependency
-> (BadDependency -> BadDependency -> Ordering)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> BadDependency)
-> (BadDependency -> BadDependency -> BadDependency)
-> Ord 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
$cp1Ord :: Eq BadDependency
Ord, Int -> BadDependency -> ShowS
[BadDependency] -> ShowS
BadDependency -> String
(Int -> BadDependency -> ShowS)
-> (BadDependency -> String)
-> ([BadDependency] -> ShowS)
-> Show BadDependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadDependency] -> ShowS
$cshowList :: [BadDependency] -> ShowS
show :: BadDependency -> String
$cshow :: BadDependency -> String
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 =
    [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
      [ String -> StyleDoc
flow String
"While constructing the build plan, the following exceptions were encountered:"
      , StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      , [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
intersperse (StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line) ((ConstructPlanException -> Maybe StyleDoc)
-> [ConstructPlanException] -> [StyleDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConstructPlanException -> Maybe StyleDoc
pprintException [ConstructPlanException]
exceptions'))
      , StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      , String -> StyleDoc
flow String
"Some different approaches to resolving this:"
      , StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      ] [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++
      (if Bool -> Bool
not Bool
onlyHasDependencyMismatches then [] else
         [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"Set 'allow-newer: true' in " StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> 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 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
         ]
      ) [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++ [StyleDoc]
addExtraDepsRecommendations

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

    addExtraDepsRecommendations :: [StyleDoc]
addExtraDepsRecommendations
      | Map PackageName (Version, BlobKey) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (Version, BlobKey)
extras = []
      | (Just (Version, BlobKey)
_) <- PackageName
-> Map PackageName (Version, BlobKey) -> Maybe (Version, BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> PackageName
mkPackageName String
"base") Map PackageName (Version, BlobKey)
extras =
          [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"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 (String -> StyleDoc
flow String
"Recommended action:") StyleDoc -> StyleDoc -> StyleDoc
<+>
            String -> StyleDoc
flow String
"try adding the following to your extra-deps in" StyleDoc -> StyleDoc -> StyleDoc
<+>
            Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
         , StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
         , [StyleDoc] -> StyleDoc
vsep (((PackageName, (Version, BlobKey)) -> StyleDoc)
-> [(PackageName, (Version, BlobKey))] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Version, BlobKey)) -> StyleDoc
forall a. IsString a => (PackageName, (Version, BlobKey)) -> a
pprintExtra (Map PackageName (Version, BlobKey)
-> [(PackageName, (Version, BlobKey))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Version, BlobKey)
extras))
         , StyleDoc
line
         ]

    extras :: Map PackageName (Version, BlobKey)
extras = [Map PackageName (Version, BlobKey)]
-> Map PackageName (Version, BlobKey)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map PackageName (Version, BlobKey)]
 -> Map PackageName (Version, BlobKey))
-> [Map PackageName (Version, BlobKey)]
-> Map PackageName (Version, BlobKey)
forall a b. (a -> b) -> a -> b
$ (ConstructPlanException -> Map PackageName (Version, BlobKey))
-> [ConstructPlanException] -> [Map PackageName (Version, BlobKey)]
forall a b. (a -> b) -> [a] -> [b]
map ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras [ConstructPlanException]
exceptions'
    getExtras :: ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras DependencyCycleDetected{} = Map PackageName (Version, BlobKey)
forall k a. Map k a
Map.empty
    getExtras UnknownPackage{} = Map PackageName (Version, BlobKey)
forall k a. Map k a
Map.empty
    getExtras (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
       [Map PackageName (Version, BlobKey)]
-> Map PackageName (Version, BlobKey)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map PackageName (Version, BlobKey)]
 -> Map PackageName (Version, BlobKey))
-> [Map PackageName (Version, BlobKey)]
-> Map PackageName (Version, BlobKey)
forall a b. (a -> b) -> a -> b
$ ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> Map PackageName (Version, BlobKey))
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [Map PackageName (Version, BlobKey)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Map PackageName (Version, BlobKey)
forall k a a b.
(k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go ([(PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))]
 -> [Map PackageName (Version, BlobKey)])
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [Map PackageName (Version, BlobKey)]
forall a b. (a -> b) -> a -> b
$ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
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)) =
           k -> (a, b) -> Map k (a, b)
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{})) =
           k -> (a, b) -> Map k (a, b)
forall k a. k -> a -> Map k a
Map.singleton k
name (a
version, b
cabalHash)
       go (k, (a, Maybe (a, b), BadDependency))
_ = Map k (a, b)
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 (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
cabalSize)
          packageIdRev :: PackageIdentifierRevision
packageIdRev = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfInfo
       in String -> a
forall a. IsString a => String -> a
fromString (String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Utf8Builder -> Text
utf8BuilderToText (PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display PackageIdentifierRevision
packageIdRev)))

    allNotInBuildPlan :: Set PackageName
allNotInBuildPlan = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (ConstructPlanException -> [PackageName])
-> [ConstructPlanException] -> [PackageName]
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) =
      ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> PackageName)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> PackageName
forall a b. (a, b) -> a
fst ([(PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))]
 -> [PackageName])
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> Bool)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName
_, (VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
badDep)) -> BadDependency
badDep BadDependency -> BadDependency -> Bool
forall a. Eq a => a -> a -> Bool
== BadDependency
NotInBuildPlan) ([(PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))]
 -> [(PackageName,
      (VersionRange, Maybe (Version, BlobKey), BadDependency))])
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
forall a b. (a -> b) -> a -> b
$ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
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 = (ConstructPlanException -> Bool)
-> [ConstructPlanException] -> Bool
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) =
          ((VersionRange, Maybe (Version, BlobKey), BadDependency) -> Bool)
-> [(VersionRange, Maybe (Version, BlobKey), BadDependency)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
depErr) -> BadDependency -> Bool
isMismatch BadDependency
depErr) (Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> [(VersionRange, Maybe (Version, BlobKey), BadDependency)]
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) = StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
        String -> StyleDoc
flow String
"Dependency cycle detected in packages:" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
        Int -> StyleDoc -> StyleDoc
indent Int
4 (StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"[" StyleDoc
"]" StyleDoc
"," ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Error (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
pNames))
    pprintException (DependencyPlanFailures Package
pkg Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
        case ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> Maybe StyleDoc)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [StyleDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Maybe StyleDoc
forall b.
(PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) of
            [] -> Maybe StyleDoc
forall a. Maybe a
Nothing
            [StyleDoc]
depErrors -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
                String -> StyleDoc
flow String
"In the dependencies for" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgIdent StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                Map FlagName Bool -> StyleDoc
pprintFlags (Package -> Map FlagName Bool
packageFlags Package
pkg) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                Int -> StyleDoc -> StyleDoc
indent Int
4 ([StyleDoc] -> StyleDoc
vsep [StyleDoc]
depErrors) StyleDoc -> StyleDoc -> StyleDoc
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 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"needed for unknown reason - stack invariant violated."
                    Just [] -> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"needed since" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgName' StyleDoc -> StyleDoc -> StyleDoc
<+> String -> StyleDoc
flow String
"is a build target."
                    Just (PackageIdentifier
target:[PackageIdentifier]
path) -> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"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 (StyleDoc -> StyleDoc)
-> (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
target] [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++
                            (PackageIdentifier -> StyleDoc)
-> [PackageIdentifier] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) [PackageIdentifier]
path [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++
                            [StyleDoc
pkgIdent]
              where
                pkgName' :: StyleDoc
pkgName' = Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
pkg
                pkgIdent :: StyleDoc
pkgIdent = Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
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 PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
allNotInBuildPlan = Maybe StyleDoc
forall a. Maybe a
Nothing
        | PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages =
            StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"Can't build a package with same name as a wired-in-package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name)
        | Just [PackageName]
pruned <- PackageName -> Map PackageName [PackageName] -> Maybe [PackageName]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName [PackageName]
prunedGlobalDeps =
            let prunedDeps :: [StyleDoc]
prunedDeps = (PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
pruned
            in StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"Can't use GHC boot package" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      (Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
                      String -> StyleDoc
flow String
"when it has an overridden dependency (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      String -> StyleDoc
flow String
"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 = StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"Unknown package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name)

    pprintFlags :: Map FlagName Bool -> StyleDoc
pprintFlags Map FlagName Bool
flags
        | Map FlagName Bool -> Bool
forall k a. Map k a -> Bool
Map.null Map FlagName Bool
flags = StyleDoc
""
        | Bool
otherwise = StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
sep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ((FlagName, Bool) -> StyleDoc) -> [(FlagName, Bool)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> StyleDoc
forall p. (Semigroup p, IsString p) => (FlagName, Bool) -> p
pprintFlag ([(FlagName, Bool)] -> [StyleDoc])
-> [(FlagName, Bool)] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ Map FlagName Bool -> [(FlagName, Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
flags
    pprintFlag :: (FlagName, Bool) -> p
pprintFlag (FlagName
name, Bool
True) = p
"+" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> String -> p
forall a. IsString a => String -> a
fromString (FlagName -> String
flagNameString FlagName
name)
    pprintFlag (FlagName
name, Bool
False) = p
"-" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> String -> p
forall a. IsString a => String -> a
fromString (FlagName -> String
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 PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map PackageName [PackageName] -> [PackageName]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map PackageName [PackageName]
prunedGlobalDeps -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
              Style -> StyleDoc -> StyleDoc
style Style
Error (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
              StyleDoc -> StyleDoc
align ((if VersionRange
range VersionRange -> VersionRange -> Bool
forall a. Eq a => a -> a -> Bool
== VersionRange
Cabal.anyVersion
                        then String -> StyleDoc
flow String
"needed"
                        else String -> StyleDoc
flow String
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                     String -> StyleDoc
flow String
"but this GHC boot package has been pruned (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     String -> StyleDoc
flow String
"you need to add the package explicitly to extra-deps" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     Maybe Version -> StyleDoc
latestApplicable Maybe Version
forall a. Maybe a
Nothing)
          | Bool
otherwise -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
              Style -> StyleDoc -> StyleDoc
style Style
Error (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
              StyleDoc -> StyleDoc
align ((if VersionRange
range VersionRange -> VersionRange -> Bool
forall a. Eq a => a -> a -> Bool
== VersionRange
Cabal.anyVersion
                        then String -> StyleDoc
flow String
"needed"
                        else String -> StyleDoc
flow String
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                     String -> StyleDoc
flow String
"but the stack configuration has no specified version" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     Maybe Version -> StyleDoc
latestApplicable Maybe Version
forall a. Maybe a
Nothing)
        -- TODO: For local packages, suggest editing constraints
        DependencyMismatch Version
version -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
            (Style -> StyleDoc -> StyleDoc
style Style
Error (StyleDoc -> StyleDoc)
-> (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"from stack configuration does not match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange StyleDoc -> StyleDoc -> StyleDoc
<+>
                   Maybe Version -> StyleDoc
latestApplicable (Version -> Maybe Version
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 -> Maybe StyleDoc
forall a. Maybe a
Nothing
        BadDependency
HasNoLibrary -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
            Style -> StyleDoc -> StyleDoc
style Style
Error (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"is a library dependency, but the package provides no library")
        BDDependencyCycleDetected [PackageName]
names -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
            Style -> StyleDoc -> StyleDoc
style Style
Error (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align (String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ String
"dependency cycle detected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
names))
      where
        goodRange :: StyleDoc
goodRange = Style -> StyleDoc -> StyleDoc
style Style
Good (String -> StyleDoc
forall a. IsString a => String -> a
fromString (VersionRange -> String
forall a. Pretty a => a -> String
Cabal.display VersionRange
range))
        latestApplicable :: Maybe Version -> StyleDoc
latestApplicable Maybe Version
mversion =
            case Maybe (Version, b)
mlatestApplicable of
                Maybe (Version, b)
Nothing
                    | Maybe Version -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Version
mversion ->
                        String -> StyleDoc
flow String
"(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 (laVer, _)
                    | Version -> Maybe Version
forall a. a -> Maybe a
Just Version
laVer Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Version
mversion -> StyleDoc
softline StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                        String -> StyleDoc
flow String
"(latest matching version is specified)"
                    | Bool
otherwise -> StyleDoc
softline StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                        String -> StyleDoc
flow String
"(latest matching version is" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
Good (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
laVer) StyleDoc -> StyleDoc -> StyleDoc
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 PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted'
        then [PackageIdentifier] -> Maybe [PackageIdentifier]
forall a. a -> Maybe a
Just []
        else case PackageName
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> Maybe (First Version, [(PackageIdentifier, VersionRange)])
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 -> Maybe [PackageIdentifier]
forall a. Maybe a
Nothing
            Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> [PackageIdentifier] -> Maybe [PackageIdentifier]
forall a. a -> Maybe a
Just ([PackageIdentifier] -> Maybe [PackageIdentifier])
-> [PackageIdentifier] -> Maybe [PackageIdentifier]
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 = [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PackageName, DepsPath)] -> Map PackageName DepsPath)
-> [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall a b. (a -> b) -> a -> b
$ ((PackageIdentifier, VersionRange) -> (PackageName, DepsPath))
-> [(PackageIdentifier, VersionRange)] -> [(PackageName, DepsPath)]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 =
        [PackageName -> Version -> PackageIdentifier
PackageIdentifier (String -> PackageName
mkPackageName String
"stack-ran-out-of-jet-fuel") ([Int] -> Version
mkVersion [Int
0])]
    findShortest Int
_ Map PackageName DepsPath
paths | Map PackageName DepsPath -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Map PackageName DepsPath -> [PackageIdentifier])
-> Map PackageName DepsPath -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ (DepsPath -> DepsPath -> DepsPath)
-> [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith DepsPath -> DepsPath -> DepsPath
chooseBest ([(PackageName, DepsPath)] -> Map PackageName DepsPath)
-> [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall a b. (a -> b) -> a -> b
$ ((PackageName, DepsPath) -> [(PackageName, DepsPath)])
-> [(PackageName, DepsPath)] -> [(PackageName, DepsPath)]
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) = [DepsPath] -> DepsPath
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (((PackageName, DepsPath) -> DepsPath)
-> [(PackageName, DepsPath)] -> [DepsPath]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, DepsPath) -> DepsPath
forall a b. (a, b) -> b
snd [(PackageName, DepsPath)]
targets) in [PackageIdentifier]
path
      where
        ([(PackageName, DepsPath)]
targets, [(PackageName, DepsPath)]
recurses) = ((PackageName, DepsPath) -> Bool)
-> [(PackageName, DepsPath)]
-> ([(PackageName, DepsPath)], [(PackageName, DepsPath)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(PackageName
n, DepsPath
_) -> PackageName
n PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wanted') (Map PackageName DepsPath -> [(PackageName, DepsPath)]
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 = if DepsPath
x DepsPath -> DepsPath -> Bool
forall a. Ord a => a -> a -> Bool
> DepsPath
y then DepsPath
x else 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 PackageName
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> Maybe (First Version, [(PackageIdentifier, VersionRange)])
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) -> ((PackageIdentifier, VersionRange) -> (PackageName, DepsPath))
-> [(PackageIdentifier, VersionRange)] -> [(PackageName, DepsPath)]
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
(DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool) -> Eq DepsPath
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
Eq DepsPath
-> (DepsPath -> DepsPath -> Ordering)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> DepsPath)
-> (DepsPath -> DepsPath -> DepsPath)
-> Ord 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
$cp1Ord :: Eq DepsPath
Ord, Int -> DepsPath -> ShowS
[DepsPath] -> ShowS
DepsPath -> String
(Int -> DepsPath -> ShowS)
-> (DepsPath -> String) -> ([DepsPath] -> ShowS) -> Show DepsPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DepsPath] -> ShowS
$cshowList :: [DepsPath] -> ShowS
show :: DepsPath -> String
$cshow :: DepsPath -> String
showsPrec :: Int -> DepsPath -> ShowS
$cshowsPrec :: Int -> DepsPath -> ShowS
Show)

startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident = DepsPath :: Int -> Int -> [PackageIdentifier] -> DepsPath
DepsPath
    { dpLength :: Int
dpLength = Int
1
    , dpNameLength :: Int
dpNameLength = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> String
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 :: Int -> Int -> [PackageIdentifier] -> DepsPath
DepsPath
    { dpLength :: Int
dpLength = DepsPath -> Int
dpLength DepsPath
dp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    , dpNameLength :: Int
dpNameLength = DepsPath -> Int
dpNameLength DepsPath
dp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> String
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 :: String -> m ()
planDebug = if Bool
False then IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn else \String
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()