{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- | cabal-install CLI command: repl
module Distribution.Client.CmdRepl
  ( -- * The @repl@ CLI and action
    replCommand
  , replAction
  , ReplFlags (..)

    -- * Internals exposed for testing
  , matchesMultipleProblem
  , selectPackageTargets
  , selectComponentTarget
  , MultiReplDecision (..)
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L

import Distribution.Client.CmdErrorMessages
  ( Plural (..)
  , componentKind
  , renderComponentKind
  , renderListCommaAnd
  , renderListSemiAnd
  , renderTargetProblem
  , renderTargetSelector
  , showTargetSelector
  , sortGroupOn
  , targetSelectorRefersToPkgs
  )
import Distribution.Client.DistDirLayout
  ( DistDirLayout (..)
  )
import Distribution.Client.Errors
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , nixStyleOptions
  )
import Distribution.Client.ProjectBuilding
  ( improveInstallPlanWithUpToDatePackages
  , rebuildTargetsDryRun
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
  ( ElaboratedInstallPlan
  , ElaboratedSharedConfig (..)
  )
import Distribution.Client.ProjectPlanning.Types
  ( elabOrderExeDependencies
  , showElaboratedInstallPlan
  )
import Distribution.Client.ScriptUtils
  ( AcceptNoTargets (..)
  , TargetContext (..)
  , fakeProjectSourcePackage
  , lSrcpkgDescription
  , updateContextAndWriteProjectFile
  , updateContextAndWriteProjectFile'
  , withContextAndSelectors
  )
import Distribution.Client.Setup
  ( ConfigFlags (..)
  , GlobalFlags
  )
import qualified Distribution.Client.Setup as Client
import Distribution.Client.TargetProblem
  ( TargetProblem (..)
  )
import Distribution.Client.Targets
  ( UserConstraint (..)
  , UserConstraintScope (..)
  )
import Distribution.Client.Types
  ( PackageSpecifier (..)
  , UnresolvedSourcePackage
  )
import Distribution.Compiler
  ( CompilerFlavor (GHC)
  )
import Distribution.Package
  ( Package (..)
  , UnitId
  , installedUnitId
  , mkPackageName
  , packageName
  )
import Distribution.Simple.Command
  ( CommandUI (..)
  , usageAlternatives
  )
import Distribution.Simple.Compiler
  ( Compiler
  , compilerCompatVersion
  )
import Distribution.Simple.Setup
  ( ReplOptions (..)
  , setupVerbosity
  )
import Distribution.Simple.Utils
  ( TempFileOptions (..)
  , debugNoWrap
  , dieWithException
  , withTempDirectoryEx
  , wrapText
  )
import Distribution.Solver.Types.ConstraintSource
  ( ConstraintSource (ConstraintSourceMultiRepl)
  )
import Distribution.Solver.Types.PackageConstraint
  ( PackageProperty (PackagePropertyVersion)
  )
import Distribution.Solver.Types.SourcePackage
  ( SourcePackage (..)
  )
import Distribution.Types.BuildInfo
  ( BuildInfo (..)
  , emptyBuildInfo
  )
import Distribution.Types.ComponentName
  ( componentNameString
  )
import Distribution.Types.CondTree
  ( CondTree (..)
  )
import Distribution.Types.Dependency
  ( Dependency (..)
  , mainLibSet
  )
import Distribution.Types.Library
  ( Library (..)
  , emptyLibrary
  )
import Distribution.Types.ParStrat
import Distribution.Types.Version
  ( Version
  , mkVersion
  )
import Distribution.Types.VersionRange
  ( anyVersion
  , orLaterVersion
  )
import Distribution.Utils.Generic
  ( safeHead
  )
import Distribution.Verbosity
  ( lessVerbose
  , normal
  )
import Language.Haskell.Extension
  ( Language (..)
  )

import Control.Monad (mapM)
import qualified Data.ByteString.Lazy as BS
import Data.List
  ( (\\)
  )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Client.ProjectConfig
  ( ProjectConfig (projectConfigShared)
  , ProjectConfigShared (projectConfigConstraints, projectConfigMultiRepl)
  )
import Distribution.Client.ReplFlags
  ( EnvFlags (envIncludeTransitive, envPackages)
  , ReplFlags (..)
  , defaultReplFlags
  , topReplOptions
  )
import Distribution.Compat.Binary (decode)
import Distribution.Simple.Flag (Flag (Flag), fromFlagOrDefault)
import Distribution.Simple.Program.Builtin (ghcProgram)
import Distribution.Simple.Program.Db (requireProgram)
import Distribution.Simple.Program.Run
  ( programInvocation
  , runProgramInvocation
  )
import Distribution.Simple.Program.Types
  ( ConfiguredProgram (programOverrideEnv)
  )
import System.Directory
  ( doesFileExist
  , getCurrentDirectory
  , listDirectory
  , makeAbsolute
  )
import System.FilePath
  ( searchPathSeparator
  , splitSearchPath
  , (</>)
  )

replCommand :: CommandUI (NixStyleFlags ReplFlags)
replCommand :: CommandUI (NixStyleFlags ReplFlags)
replCommand =
  CommandUI
  (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
   BenchmarkFlags)
Client.installCommand
    { commandName = "v2-repl"
    , commandSynopsis = "Open an interactive session for the given component."
    , commandUsage = usageAlternatives "v2-repl" ["[TARGET] [FLAGS]"]
    , commandDescription = Just $ \[Char]
_ ->
        [Char] -> [Char]
wrapText ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
          [Char]
"Open an interactive session for a component within the project. The "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"available targets are the same as for the 'v2-build' command: "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"individual components within packages in the project, including "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"libraries, executables, test-suites or benchmarks. Packages can "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"also be specified in which case the library component in the "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"package will be used, or the (first listed) executable in the "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"package if there is no library.\n\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Dependencies are built or rebuilt as necessary. Additional "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"configuration flags can be specified on the command line and these "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"extend the project configuration from the 'cabal.project', "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'cabal.project.local' and other files."
    , commandNotes = Just $ \[Char]
pname ->
        [Char]
"Examples, open an interactive session:\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    for the default component in the package in the current directory\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl pkgname\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    for the default component in the package named 'pkgname'\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl ./pkgfoo\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    for the default component in the package in the ./pkgfoo directory\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl cname\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    for the component named 'cname'\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl pkgname:cname\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    for the component 'cname' in the package 'pkgname'\n\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl --build-depends lens\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    add the latest version of the library 'lens' to the default component "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(or no componentif there is no project present)\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    add a version (constrained between 4.15 and 4.18) of the library 'lens' "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"to the default component (or no component if there is no project present)\n"
    , commandDefaultFlags = defaultNixStyleFlags defaultReplFlags
    , commandOptions = nixStyleOptions topReplOptions
    }

data MultiReplDecision = MultiReplDecision
  { MultiReplDecision -> Maybe Version
compilerVersion :: Maybe Version
  , MultiReplDecision -> Bool
enabledByFlag :: Bool
  }
  deriving (MultiReplDecision -> MultiReplDecision -> Bool
(MultiReplDecision -> MultiReplDecision -> Bool)
-> (MultiReplDecision -> MultiReplDecision -> Bool)
-> Eq MultiReplDecision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MultiReplDecision -> MultiReplDecision -> Bool
== :: MultiReplDecision -> MultiReplDecision -> Bool
$c/= :: MultiReplDecision -> MultiReplDecision -> Bool
/= :: MultiReplDecision -> MultiReplDecision -> Bool
Eq, Int -> MultiReplDecision -> [Char] -> [Char]
[MultiReplDecision] -> [Char] -> [Char]
MultiReplDecision -> [Char]
(Int -> MultiReplDecision -> [Char] -> [Char])
-> (MultiReplDecision -> [Char])
-> ([MultiReplDecision] -> [Char] -> [Char])
-> Show MultiReplDecision
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> MultiReplDecision -> [Char] -> [Char]
showsPrec :: Int -> MultiReplDecision -> [Char] -> [Char]
$cshow :: MultiReplDecision -> [Char]
show :: MultiReplDecision -> [Char]
$cshowList :: [MultiReplDecision] -> [Char] -> [Char]
showList :: [MultiReplDecision] -> [Char] -> [Char]
Show)

useMultiRepl :: MultiReplDecision -> Bool
useMultiRepl :: MultiReplDecision -> Bool
useMultiRepl MultiReplDecision{Maybe Version
compilerVersion :: MultiReplDecision -> Maybe Version
compilerVersion :: Maybe Version
compilerVersion, Bool
enabledByFlag :: MultiReplDecision -> Bool
enabledByFlag :: Bool
enabledByFlag} =
  Maybe Version
compilerVersion Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version -> Maybe Version
forall a. a -> Maybe a
Just Version
minMultipleHomeUnitsVersion Bool -> Bool -> Bool
&& Bool
enabledByFlag

multiReplDecision :: ProjectConfigShared -> Compiler -> ReplFlags -> MultiReplDecision
multiReplDecision :: ProjectConfigShared -> Compiler -> ReplFlags -> MultiReplDecision
multiReplDecision ProjectConfigShared
ctx Compiler
compiler ReplFlags
flags =
  Maybe Version -> Bool -> MultiReplDecision
MultiReplDecision
    -- Check if the compiler is new enough, need at least 9.4 to start a multi session
    (CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC Compiler
compiler)
    -- Then check the user actually asked for it, either via the project file, the global config or
    -- a repl specific option.
    (Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ProjectConfigShared -> Flag Bool
projectConfigMultiRepl ProjectConfigShared
ctx Flag Bool -> Flag Bool -> Flag Bool
forall a. Semigroup a => a -> a -> a
<> ReplFlags -> Flag Bool
replUseMulti ReplFlags
flags))

-- | The @repl@ command is very much like @build@. It brings the install plan
-- up to date, selects that part of the plan needed by the given or implicit
-- repl target and then executes the plan.
--
-- Compared to @build@ the difference is that multiple targets are handled
-- specially and the target type is repl rather than build. The
-- general plan execution infrastructure handles both build and repl targets.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO ()
replAction :: NixStyleFlags ReplFlags -> [[Char]] -> GlobalFlags -> IO ()
replAction flags :: NixStyleFlags ReplFlags
flags@NixStyleFlags{extraFlags :: forall a. NixStyleFlags a -> a
extraFlags = r :: ReplFlags
r@ReplFlags{Flag Bool
ReplOptions
EnvFlags
replUseMulti :: ReplFlags -> Flag Bool
configureReplOptions :: ReplOptions
replEnvFlags :: EnvFlags
replUseMulti :: Flag Bool
replKeepTempFiles :: Flag Bool
configureReplOptions :: ReplFlags -> ReplOptions
replEnvFlags :: ReplFlags -> EnvFlags
replKeepTempFiles :: ReplFlags -> Flag Bool
..}, TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
..} [[Char]]
targetStrings GlobalFlags
globalFlags =
  AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags ReplFlags
-> [[Char]]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [[Char]]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
AcceptNoTargets (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
LibKind) NixStyleFlags ReplFlags
flags [[Char]]
targetStrings GlobalFlags
globalFlags CurrentCommand
ReplCommand ((TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO ())
 -> IO ())
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
ctx)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
ReplCommandDoesn'tSupport
    let projectRoot :: [Char]
projectRoot = DistDirLayout -> [Char]
distProjectRootDirectory (DistDirLayout -> [Char]) -> DistDirLayout -> [Char]
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx
        distDir :: [Char]
distDir = DistDirLayout -> [Char]
distDirectory (DistDirLayout -> [Char]) -> DistDirLayout -> [Char]
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx

    ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      TargetContext
GlobalContext -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
targetStrings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
            [[Char]] -> CabalInstallException
ReplTakesNoArguments [[Char]]
targetStrings
        let
          sourcePackage :: SourcePackage (PackageLocation loc)
sourcePackage =
            [Char] -> SourcePackage (PackageLocation loc)
forall loc. [Char] -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage [Char]
projectRoot
              SourcePackage (PackageLocation loc)
-> (SourcePackage (PackageLocation loc)
    -> SourcePackage (PackageLocation loc))
-> SourcePackage (PackageLocation loc)
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  (SourcePackage (PackageLocation loc))
  (SourcePackage (PackageLocation loc))
  GenericPackageDescription
  GenericPackageDescription
forall loc (f :: * -> *).
Functor f =>
LensLike
  f
  (SourcePackage loc)
  (SourcePackage loc)
  GenericPackageDescription
  GenericPackageDescription
lSrcpkgDescription LensLike
  Identity
  (SourcePackage (PackageLocation loc))
  (SourcePackage (PackageLocation loc))
  GenericPackageDescription
  GenericPackageDescription
-> ((Maybe (CondTree ConfVar [Dependency] Library)
     -> Identity (Maybe (CondTree ConfVar [Dependency] Library)))
    -> GenericPackageDescription -> Identity GenericPackageDescription)
-> (Maybe (CondTree ConfVar [Dependency] Library)
    -> Identity (Maybe (CondTree ConfVar [Dependency] Library)))
-> SourcePackage (PackageLocation loc)
-> Identity (SourcePackage (PackageLocation loc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (CondTree ConfVar [Dependency] Library)
 -> Identity (Maybe (CondTree ConfVar [Dependency] Library)))
-> GenericPackageDescription -> Identity GenericPackageDescription
Lens'
  GenericPackageDescription
  (Maybe (CondTree ConfVar [Dependency] Library))
L.condLibrary
                ((Maybe (CondTree ConfVar [Dependency] Library)
  -> Identity (Maybe (CondTree ConfVar [Dependency] Library)))
 -> SourcePackage (PackageLocation loc)
 -> Identity (SourcePackage (PackageLocation loc)))
-> Maybe (CondTree ConfVar [Dependency] Library)
-> SourcePackage (PackageLocation loc)
-> SourcePackage (PackageLocation loc)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CondTree ConfVar [Dependency] Library
-> Maybe (CondTree ConfVar [Dependency] Library)
forall a. a -> Maybe a
Just (Library
-> [Dependency]
-> [CondBranch ConfVar [Dependency] Library]
-> CondTree ConfVar [Dependency] Library
forall v c a. a -> c -> [CondBranch v c a] -> CondTree v c a
CondNode Library
library [Dependency
baseDep] [])
          library :: Library
library = Library
emptyLibrary{libBuildInfo = lBuildInfo}
          lBuildInfo :: BuildInfo
lBuildInfo =
            BuildInfo
emptyBuildInfo
              { targetBuildDepends = [baseDep]
              , defaultLanguage = Just Haskell2010
              }
          baseDep :: Dependency
baseDep = PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
"base" VersionRange
anyVersion NonEmptySet LibraryName
mainLibSet

        ProjectBaseContext
-> UnresolvedSourcePackage -> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx UnresolvedSourcePackage
forall {loc}. SourcePackage (PackageLocation loc)
sourcePackage
      ScriptContext [Char]
scriptPath Executable
scriptExecutable -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
targetStrings Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
            [[Char]] -> CabalInstallException
ReplTakesSingleArgument [[Char]]
targetStrings
        Bool
existsScriptPath <- [Char] -> IO Bool
doesFileExist [Char]
scriptPath
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
existsScriptPath (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
            [[Char]] -> CabalInstallException
ReplTakesSingleArgument [[Char]]
targetStrings

        ProjectBaseContext -> [Char] -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx [Char]
scriptPath Executable
scriptExecutable

    -- If multi-repl is used, we need a Cabal recent enough to handle it.
    -- We need to do this before solving, but the compiler version is only known
    -- after solving (phaseConfigureCompiler), so instead of using
    -- multiReplDecision we just check the flag.
    let baseCtx' :: ProjectBaseContext
baseCtx' =
          if Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$
            ProjectConfigShared -> Flag Bool
projectConfigMultiRepl (ProjectConfig -> ProjectConfigShared
projectConfigShared (ProjectConfig -> ProjectConfigShared)
-> ProjectConfig -> ProjectConfigShared
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
baseCtx)
              Flag Bool -> Flag Bool -> Flag Bool
forall a. Semigroup a => a -> a -> a
<> Flag Bool
replUseMulti
            then
              ProjectBaseContext
baseCtx
                ProjectBaseContext
-> (ProjectBaseContext -> ProjectBaseContext) -> ProjectBaseContext
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  ProjectBaseContext
  ProjectBaseContext
  ProjectConfig
  ProjectConfig
Lens' ProjectBaseContext ProjectConfig
lProjectConfig LensLike
  Identity
  ProjectBaseContext
  ProjectBaseContext
  ProjectConfig
  ProjectConfig
-> (([(UserConstraint, ConstraintSource)]
     -> Identity [(UserConstraint, ConstraintSource)])
    -> ProjectConfig -> Identity ProjectConfig)
-> ([(UserConstraint, ConstraintSource)]
    -> Identity [(UserConstraint, ConstraintSource)])
-> ProjectBaseContext
-> Identity ProjectBaseContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike
  Identity
  ProjectConfig
  ProjectConfig
  ProjectConfigShared
  ProjectConfigShared
Lens' ProjectConfig ProjectConfigShared
lProjectConfigShared LensLike
  Identity
  ProjectConfig
  ProjectConfig
  ProjectConfigShared
  ProjectConfigShared
-> (([(UserConstraint, ConstraintSource)]
     -> Identity [(UserConstraint, ConstraintSource)])
    -> ProjectConfigShared -> Identity ProjectConfigShared)
-> ([(UserConstraint, ConstraintSource)]
    -> Identity [(UserConstraint, ConstraintSource)])
-> ProjectConfig
-> Identity ProjectConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(UserConstraint, ConstraintSource)]
 -> Identity [(UserConstraint, ConstraintSource)])
-> ProjectConfigShared -> Identity ProjectConfigShared
Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]
lProjectConfigConstraints
                  (([(UserConstraint, ConstraintSource)]
  -> Identity [(UserConstraint, ConstraintSource)])
 -> ProjectBaseContext -> Identity ProjectBaseContext)
-> ([(UserConstraint, ConstraintSource)]
    -> [(UserConstraint, ConstraintSource)])
-> ProjectBaseContext
-> ProjectBaseContext
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((UserConstraint, ConstraintSource)
multiReplCabalConstraint (UserConstraint, ConstraintSource)
-> [(UserConstraint, ConstraintSource)]
-> [(UserConstraint, ConstraintSource)]
forall a. a -> [a] -> [a]
:)
            else ProjectBaseContext
baseCtx

    (Maybe OriginalComponentInfo
originalComponent, ProjectBaseContext
baseCtx'') <-
      if [Dependency] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EnvFlags -> [Dependency]
envPackages EnvFlags
replEnvFlags)
        then (Maybe OriginalComponentInfo, ProjectBaseContext)
-> IO (Maybe OriginalComponentInfo, ProjectBaseContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OriginalComponentInfo
forall a. Maybe a
Nothing, ProjectBaseContext
baseCtx')
        else -- Unfortunately, the best way to do this is to let the normal solver
        -- help us resolve the targets, but that isn't ideal for performance,
        -- especially in the no-project case.
        Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> ElaboratedSharedConfig
    -> IO (Maybe OriginalComponentInfo, ProjectBaseContext))
-> IO (Maybe OriginalComponentInfo, ProjectBaseContext)
forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan (Verbosity -> Verbosity
lessVerbose Verbosity
verbosity) ProjectBaseContext
baseCtx' ((ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> IO (Maybe OriginalComponentInfo, ProjectBaseContext))
 -> IO (Maybe OriginalComponentInfo, ProjectBaseContext))
-> (ElaboratedInstallPlan
    -> ElaboratedSharedConfig
    -> IO (Maybe OriginalComponentInfo, ProjectBaseContext))
-> IO (Maybe OriginalComponentInfo, ProjectBaseContext)
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
sharedConfig -> do
          -- targets should be non-empty map, but there's no NonEmptyMap yet.
          TargetsMap
targets <- ProjectConfigShared
-> Compiler
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO TargetsMap
validatedTargets (ProjectConfig -> ProjectConfigShared
projectConfigShared (ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
ctx)) (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
sharedConfig) ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors

          let
            (UnitId
unitId, [(ComponentTarget, NonEmpty TargetSelector)]
_) = (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a. HasCallStack => [Char] -> a
error [Char]
"panic: targets should be non-empty") (Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
 -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]))
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a b. (a -> b) -> a -> b
$ [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a. [a] -> Maybe a
safeHead ([(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
 -> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]))
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a b. (a -> b) -> a -> b
$ TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
forall k a. Map k a -> [(k, a)]
Map.toList TargetsMap
targets
            originalDeps :: [UnitId]
originalDeps = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> UnitId)
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [UnitId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElaboratedInstallPlan
-> UnitId
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.directDeps ElaboratedInstallPlan
elaboratedPlan UnitId
unitId
            oci :: OriginalComponentInfo
oci = UnitId -> [UnitId] -> OriginalComponentInfo
OriginalComponentInfo UnitId
unitId [UnitId]
originalDeps
            pkgId :: PackageIdentifier
pkgId = PackageIdentifier -> Maybe PackageIdentifier -> PackageIdentifier
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> PackageIdentifier
forall a. HasCallStack => [Char] -> a
error ([Char] -> PackageIdentifier) -> [Char] -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ [Char]
"cannot find " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow UnitId
unitId) (Maybe PackageIdentifier -> PackageIdentifier)
-> Maybe PackageIdentifier -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> PackageIdentifier)
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
-> Maybe PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElaboratedInstallPlan
-> UnitId
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> UnitId -> Maybe (GenericPlanPackage ipkg srcpkg)
InstallPlan.lookup ElaboratedInstallPlan
elaboratedPlan UnitId
unitId
            baseCtx'' :: ProjectBaseContext
baseCtx'' = [Dependency]
-> PackageIdentifier -> ProjectBaseContext -> ProjectBaseContext
addDepsToProjectTarget (EnvFlags -> [Dependency]
envPackages EnvFlags
replEnvFlags) PackageIdentifier
pkgId ProjectBaseContext
baseCtx'

          (Maybe OriginalComponentInfo, ProjectBaseContext)
-> IO (Maybe OriginalComponentInfo, ProjectBaseContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OriginalComponentInfo -> Maybe OriginalComponentInfo
forall a. a -> Maybe a
Just OriginalComponentInfo
oci, ProjectBaseContext
baseCtx'')

    -- Now, we run the solver again with the added packages. While the graph
    -- won't actually reflect the addition of transitive dependencies,
    -- they're going to be available already and will be offered to the REPL
    -- and that's good enough.
    --
    -- In addition, to avoid a *third* trip through the solver, we are
    -- replicating the second half of 'runProjectPreBuildPhase' by hand
    -- here.
    (ProjectBuildContext
buildCtx, Compiler
compiler, ReplOptions
replOpts', TargetsMap
targets) <- Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> ElaboratedSharedConfig
    -> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap))
-> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap)
forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan Verbosity
verbosity ProjectBaseContext
baseCtx'' ((ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap))
 -> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap))
-> (ElaboratedInstallPlan
    -> ElaboratedSharedConfig
    -> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap))
-> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap)
forall a b. (a -> b) -> a -> b
$
      \ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
elaboratedShared' -> do
        let ProjectBaseContext{[PackageSpecifier UnresolvedSourcePackage]
Maybe InstalledPackageIndex
BuildTimeSettings
ProjectConfig
CabalDirLayout
DistDirLayout
CurrentCommand
buildSettings :: ProjectBaseContext -> BuildTimeSettings
distDirLayout :: ProjectBaseContext -> DistDirLayout
projectConfig :: ProjectBaseContext -> ProjectConfig
distDirLayout :: DistDirLayout
cabalDirLayout :: CabalDirLayout
projectConfig :: ProjectConfig
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
buildSettings :: BuildTimeSettings
currentCommand :: CurrentCommand
installedPackages :: Maybe InstalledPackageIndex
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
currentCommand :: ProjectBaseContext -> CurrentCommand
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
..} = ProjectBaseContext
baseCtx''

        -- Recalculate with updated project.
        TargetsMap
targets <- ProjectConfigShared
-> Compiler
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO TargetsMap
validatedTargets (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
projectConfig) (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
elaboratedShared') ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors

        let
          elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' =
            TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
              TargetAction
TargetActionRepl
              TargetsMap
targets
              ElaboratedInstallPlan
elaboratedPlan
          includeTransitive :: Bool
includeTransitive = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
True (EnvFlags -> Flag Bool
envIncludeTransitive EnvFlags
replEnvFlags)

        BuildStatusMap
pkgsBuildStatus <-
          DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> IO BuildStatusMap
rebuildTargetsDryRun
            DistDirLayout
distDirLayout
            ElaboratedSharedConfig
elaboratedShared'
            ElaboratedInstallPlan
elaboratedPlan'

        let elaboratedPlan'' :: ElaboratedInstallPlan
elaboratedPlan'' =
              BuildStatusMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages
                BuildStatusMap
pkgsBuildStatus
                ElaboratedInstallPlan
elaboratedPlan'
        Verbosity -> [Char] -> IO ()
debugNoWrap Verbosity
verbosity (ElaboratedInstallPlan -> [Char]
showElaboratedInstallPlan ElaboratedInstallPlan
elaboratedPlan'')

        let
          buildCtx :: ProjectBuildContext
buildCtx =
            ProjectBuildContext
              { elaboratedPlanOriginal :: ElaboratedInstallPlan
elaboratedPlanOriginal = ElaboratedInstallPlan
elaboratedPlan
              , elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedPlanToExecute = ElaboratedInstallPlan
elaboratedPlan''
              , elaboratedShared :: ElaboratedSharedConfig
elaboratedShared = ElaboratedSharedConfig
elaboratedShared'
              , BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus
              , targetsMap :: TargetsMap
targetsMap = TargetsMap
targets
              }

          ElaboratedSharedConfig{pkgConfigCompiler :: ElaboratedSharedConfig -> Compiler
pkgConfigCompiler = Compiler
compiler} = ElaboratedSharedConfig
elaboratedShared'

          repl_flags :: [[Char]]
repl_flags = case Maybe OriginalComponentInfo
originalComponent of
            Just OriginalComponentInfo
oci -> Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [[Char]]
generateReplFlags Bool
includeTransitive ElaboratedInstallPlan
elaboratedPlan' OriginalComponentInfo
oci
            Maybe OriginalComponentInfo
Nothing -> []

        (ProjectBuildContext, Compiler, ReplOptions, TargetsMap)
-> IO (ProjectBuildContext, Compiler, ReplOptions, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBuildContext
buildCtx, Compiler
compiler, ReplOptions
configureReplOptions ReplOptions -> (ReplOptions -> ReplOptions) -> ReplOptions
forall a b. a -> (a -> b) -> b
& LensLike Identity ReplOptions ReplOptions [[Char]] [[Char]]
Lens' ReplOptions [[Char]]
lReplOptionsFlags LensLike Identity ReplOptions ReplOptions [[Char]] [[Char]]
-> ([[Char]] -> [[Char]]) -> ReplOptions -> ReplOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
repl_flags), TargetsMap
targets)

    -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for
    -- a high-level overview about how everything fits together.
    if Set (UnitId, ComponentName) -> Int
forall a. Set a -> Int
Set.size (TargetsMap -> Set (UnitId, ComponentName)
distinctTargetComponents TargetsMap
targets) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      then Verbosity
-> TempFileOptions
-> [Char]
-> [Char]
-> ([Char] -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions -> [Char] -> [Char] -> ([Char] -> IO a) -> IO a
withTempDirectoryEx Verbosity
verbosity (Bool -> TempFileOptions
TempFileOptions Bool
keepTempFiles) [Char]
distDir [Char]
"multi-out" (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir' -> do
        -- multi target repl
        [Char]
dir <- [Char] -> IO [Char]
makeAbsolute [Char]
dir'
        -- Modify the replOptions so that the ./Setup repl command will write options
        -- into the multi-out directory.
        ReplOptions
replOpts'' <- case TargetContext
targetCtx of
          TargetContext
ProjectContext -> ReplOptions -> IO ReplOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReplOptions -> IO ReplOptions) -> ReplOptions -> IO ReplOptions
forall a b. (a -> b) -> a -> b
$ ReplOptions
replOpts'{replOptionsFlagOutput = Flag dir}
          TargetContext
_ -> Compiler -> [Char] -> ReplOptions -> IO ReplOptions
usingGhciScript Compiler
compiler [Char]
projectRoot ReplOptions
replOpts'

        let buildCtx' :: ProjectBuildContext
buildCtx' = ProjectBuildContext
buildCtx ProjectBuildContext
-> (ProjectBuildContext -> ProjectBuildContext)
-> ProjectBuildContext
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  ProjectBuildContext
  ProjectBuildContext
  ElaboratedSharedConfig
  ElaboratedSharedConfig
Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared LensLike
  Identity
  ProjectBuildContext
  ProjectBuildContext
  ElaboratedSharedConfig
  ElaboratedSharedConfig
-> ((ReplOptions -> Identity ReplOptions)
    -> ElaboratedSharedConfig -> Identity ElaboratedSharedConfig)
-> (ReplOptions -> Identity ReplOptions)
-> ProjectBuildContext
-> Identity ProjectBuildContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReplOptions -> Identity ReplOptions)
-> ElaboratedSharedConfig -> Identity ElaboratedSharedConfig
Lens' ElaboratedSharedConfig ReplOptions
lPkgConfigReplOptions ((ReplOptions -> Identity ReplOptions)
 -> ProjectBuildContext -> Identity ProjectBuildContext)
-> ReplOptions -> ProjectBuildContext -> ProjectBuildContext
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReplOptions
replOpts''
        Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx'' ProjectBuildContext
buildCtx'

        -- The project build phase will call `./Setup repl` but write the options
        -- out into a file without starting a repl.
        BuildOutcomes
buildOutcomes <- Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx'' ProjectBuildContext
buildCtx'
        Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx'' ProjectBuildContext
buildCtx' BuildOutcomes
buildOutcomes

        -- calculate PATH, we construct a PATH which is the union of all paths from
        -- the units which have been loaded. This is not quite right but usually works fine.
        [[Char]]
path_files <- [Char] -> IO [[Char]]
listDirectory ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"paths")

        -- Note: decode is partial. Should we use Structured here?
        -- This might blow up with @build-type: Custom@ stuff.
        [ConfiguredProgram]
ghcProgs <- ([Char] -> IO ConfiguredProgram)
-> [[Char]] -> IO [ConfiguredProgram]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\[Char]
f -> forall a. Binary a => ByteString -> a
decode @ConfiguredProgram (ByteString -> ConfiguredProgram)
-> IO ByteString -> IO ConfiguredProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BS.readFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"paths" [Char] -> [Char] -> [Char]
</> [Char]
f)) [[Char]]
path_files

        let all_paths :: [([Char], Maybe [Char])]
all_paths = (ConfiguredProgram -> [([Char], Maybe [Char])])
-> [ConfiguredProgram] -> [([Char], Maybe [Char])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConfiguredProgram -> [([Char], Maybe [Char])]
programOverrideEnv [ConfiguredProgram]
ghcProgs
        let sp :: [Char]
sp = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ((([Char], Int) -> [Char]) -> [([Char], Int)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Int) -> [Char]
forall a b. (a, b) -> a
fst ((([Char], Int) -> ([Char], Int) -> Ordering)
-> [([Char], Int)] -> [([Char], Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing @Int ([Char], Int) -> Int
forall a b. (a, b) -> b
snd) ([([Char], Int)] -> [([Char], Int)])
-> [([Char], Int)] -> [([Char], Int)]
forall a b. (a -> b) -> a -> b
$ Map [Char] Int -> [([Char], Int)]
forall k a. Map k a -> [(k, a)]
Map.toList ([([Char], Maybe [Char])] -> Map [Char] Int
forall {t :: * -> *} {a} {a}.
(Foldable t, Eq a, IsString a, Num a) =>
t (a, Maybe [Char]) -> Map [Char] a
combine_search_paths [([Char], Maybe [Char])]
all_paths)))
        -- HACK: Just combine together all env overrides, placing the most common things last

        -- ghc program with overriden PATH
        (ConfiguredProgram
ghcProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram (ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs (ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared ProjectBuildContext
buildCtx'))
        let ghcProg' :: ConfiguredProgram
ghcProg' = ConfiguredProgram
ghcProg{programOverrideEnv = [("PATH", Just sp)]}

        -- Find what the unit files are, and start a repl based on all the response
        -- files which have been created in the directory.
        -- unit files for components
        [[Char]]
unit_files <- [Char] -> IO [[Char]]
listDirectory [Char]
dir

        -- Order the unit files so that the find target becomes the active unit
        let active_unit_fp :: Maybe FilePath
            active_unit_fp :: Maybe [Char]
active_unit_fp = do
              -- Get the first target selectors from the cli
              TargetSelector
activeTarget <- [TargetSelector] -> Maybe TargetSelector
forall a. [a] -> Maybe a
safeHead [TargetSelector]
targetSelectors
              -- Lookup the targets :: Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]
              UnitId
unitId <-
                TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
forall k a. Map k a -> [(k, a)]
Map.toList TargetsMap
targets
                  -- Keep the UnitId matching the desired target selector
                  [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> ([(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
    -> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]))
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a b. a -> (a -> b) -> b
& ((UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> Bool)
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(UnitId
_, [(ComponentTarget, NonEmpty TargetSelector)]
xs) -> ((ComponentTarget, NonEmpty TargetSelector) -> Bool)
-> [(ComponentTarget, NonEmpty TargetSelector)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(ComponentTarget
_, NonEmpty TargetSelector
selectors) -> TargetSelector
activeTarget TargetSelector -> NonEmpty TargetSelector -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty TargetSelector
selectors) [(ComponentTarget, NonEmpty TargetSelector)]
xs)
                  Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> (Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
    -> Maybe UnitId)
-> Maybe UnitId
forall a b. a -> (a -> b) -> b
& ((UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> UnitId)
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> Maybe UnitId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> UnitId
forall a b. (a, b) -> a
fst
              -- Convert to filename (adapted from 'storePackageDirectory')
              [Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow UnitId
unitId)
            unit_files_ordered :: [FilePath]
            unit_files_ordered :: [[Char]]
unit_files_ordered =
              let ([[Char]]
active_unit_files, [[Char]]
other_units) = ([Char] -> Bool) -> [[Char]] -> ([[Char]], [[Char]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[Char]
fp -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
fp Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Char]
active_unit_fp) [[Char]]
unit_files
               in -- GHC considers the last unit passed to be the active one
                  [[Char]]
other_units [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
active_unit_files

            render_j :: ParStratX Int -> [Char]
render_j ParStratX Int
Serial = [Char]
"1"
            render_j (UseSem Int
n) = forall a. Show a => a -> [Char]
show @Int Int
n
            render_j (NumJobs Maybe Int
mn) = [Char] -> (Int -> [Char]) -> Maybe Int -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (forall a. Show a => a -> [Char]
show @Int) Maybe Int
mn

        -- run ghc --interactive with
        Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$
          ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocation ConfiguredProgram
ghcProg' ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
            [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
              [ [Char]
"--interactive"
              , [Char]
"-package-env"
              , [Char]
"-" -- to ignore ghc.environment.* files
              , [Char]
"-j"
              , ParStratX Int -> [Char]
render_j (BuildTimeSettings -> ParStratX Int
buildSettingNumJobs (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
ctx))
              ]
                [[Char]] -> [[[Char]]] -> [[[Char]]]
forall a. a -> [a] -> [a]
: [ [[Char]
"-unit", [Char]
"@" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
unit]
                  | [Char]
unit <- [[Char]]
unit_files_ordered
                  , [Char]
unit [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"paths"
                  ]

        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else do
        -- single target repl
        ReplOptions
replOpts'' <- case TargetContext
targetCtx of
          TargetContext
ProjectContext -> ReplOptions -> IO ReplOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ReplOptions
replOpts'
          TargetContext
_ -> Compiler -> [Char] -> ReplOptions -> IO ReplOptions
usingGhciScript Compiler
compiler [Char]
projectRoot ReplOptions
replOpts'

        let buildCtx' :: ProjectBuildContext
buildCtx' = ProjectBuildContext
buildCtx ProjectBuildContext
-> (ProjectBuildContext -> ProjectBuildContext)
-> ProjectBuildContext
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  ProjectBuildContext
  ProjectBuildContext
  ElaboratedSharedConfig
  ElaboratedSharedConfig
Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared LensLike
  Identity
  ProjectBuildContext
  ProjectBuildContext
  ElaboratedSharedConfig
  ElaboratedSharedConfig
-> ((ReplOptions -> Identity ReplOptions)
    -> ElaboratedSharedConfig -> Identity ElaboratedSharedConfig)
-> (ReplOptions -> Identity ReplOptions)
-> ProjectBuildContext
-> Identity ProjectBuildContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReplOptions -> Identity ReplOptions)
-> ElaboratedSharedConfig -> Identity ElaboratedSharedConfig
Lens' ElaboratedSharedConfig ReplOptions
lPkgConfigReplOptions ((ReplOptions -> Identity ReplOptions)
 -> ProjectBuildContext -> Identity ProjectBuildContext)
-> ReplOptions -> ProjectBuildContext -> ProjectBuildContext
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ReplOptions
replOpts''
        Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx'' ProjectBuildContext
buildCtx'

        BuildOutcomes
buildOutcomes <- Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx'' ProjectBuildContext
buildCtx'
        Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx'' ProjectBuildContext
buildCtx' BuildOutcomes
buildOutcomes
  where
    combine_search_paths :: t (a, Maybe [Char]) -> Map [Char] a
combine_search_paths t (a, Maybe [Char])
paths =
      (Map [Char] a -> (a, Maybe [Char]) -> Map [Char] a)
-> Map [Char] a -> t (a, Maybe [Char]) -> Map [Char] a
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map [Char] a -> (a, Maybe [Char]) -> Map [Char] a
forall {a} {a}.
(Eq a, IsString a, Num a) =>
Map [Char] a -> (a, Maybe [Char]) -> Map [Char] a
go Map [Char] a
forall k a. Map k a
Map.empty t (a, Maybe [Char])
paths
      where
        go :: Map [Char] a -> (a, Maybe [Char]) -> Map [Char] a
go Map [Char] a
m (a
"PATH", Just [Char]
s) = (Map [Char] a -> [Char] -> Map [Char] a)
-> Map [Char] a -> [[Char]] -> Map [Char] a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map [Char] a
m' [Char]
f -> (a -> a -> a) -> [Char] -> a -> Map [Char] a -> Map [Char] a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) [Char]
f a
1 Map [Char] a
m') Map [Char] a
m ([Char] -> [[Char]]
splitSearchPath [Char]
s)
        go Map [Char] a
m (a, Maybe [Char])
_ = Map [Char] a
m

    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)
    keepTempFiles :: Bool
keepTempFiles = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False Flag Bool
replKeepTempFiles

    validatedTargets :: ProjectConfigShared
-> Compiler
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO TargetsMap
validatedTargets ProjectConfigShared
ctx Compiler
compiler ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors = do
      let multi_repl_enabled :: MultiReplDecision
multi_repl_enabled = ProjectConfigShared -> Compiler -> ReplFlags -> MultiReplDecision
multiReplDecision ProjectConfigShared
ctx Compiler
compiler ReplFlags
r
      -- Interpret the targets on the command line as repl targets
      -- (as opposed to say build or haddock targets).
      TargetsMap
targets <-
        ([TargetProblem ReplProblem] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem ReplProblem] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetProblem ReplProblem] -> IO TargetsMap
forall a. Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem ReplProblem] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem ReplProblem] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
          (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem ReplProblem) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem ReplProblem] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
            (MultiReplDecision
-> TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ReplProblem) [k]
forall k.
MultiReplDecision
-> TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ReplProblem) [k]
selectPackageTargets MultiReplDecision
multi_repl_enabled)
            SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ReplProblem) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ReplProblem) k
selectComponentTarget
            ElaboratedInstallPlan
elaboratedPlan
            Maybe SourcePackageDb
forall a. Maybe a
Nothing
            [TargetSelector]
targetSelectors

      -- Reject multiple targets, or at least targets in different
      -- components. It is ok to have two module/file targets in the
      -- same component, but not two that live in different components.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set (UnitId, ComponentName) -> Int
forall a. Set a -> Int
Set.size (TargetsMap -> Set (UnitId, ComponentName)
distinctTargetComponents TargetsMap
targets) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not (MultiReplDecision -> Bool
useMultiRepl MultiReplDecision
multi_repl_enabled)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> [TargetProblem ReplProblem] -> IO ()
forall a. Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems
          Verbosity
verbosity
          [MultiReplDecision -> TargetsMap -> TargetProblem ReplProblem
multipleTargetsProblem MultiReplDecision
multi_repl_enabled TargetsMap
targets]

      TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TargetsMap
targets

    -- This is the constraint setup.Cabal>=3.11. 3.11 is when Cabal options
    -- used for multi-repl were introduced.
    -- Idelly we'd apply this constraint only on the closure of repl targets,
    -- but that would require another solver run for marginal advantages that
    -- will further shrink as 3.11 is adopted.
    multiReplCabalConstraint :: (UserConstraint, ConstraintSource)
multiReplCabalConstraint =
      ( UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint
          (PackageName -> UserConstraintScope
UserAnySetupQualifier ([Char] -> PackageName
mkPackageName [Char]
"Cabal"))
          (VersionRange -> PackageProperty
PackagePropertyVersion (VersionRange -> PackageProperty)
-> VersionRange -> PackageProperty
forall a b. (a -> b) -> a -> b
$ Version -> VersionRange
orLaterVersion (Version -> VersionRange) -> Version -> VersionRange
forall a b. (a -> b) -> a -> b
$ [Int] -> Version
mkVersion [Int
3, Int
11])
      , ConstraintSource
ConstraintSourceMultiRepl
      )

-- | First version of GHC which supports multiple home packages
minMultipleHomeUnitsVersion :: Version
minMultipleHomeUnitsVersion :: Version
minMultipleHomeUnitsVersion = [Int] -> Version
mkVersion [Int
9, Int
4]

data OriginalComponentInfo = OriginalComponentInfo
  { OriginalComponentInfo -> UnitId
ociUnitId :: UnitId
  , OriginalComponentInfo -> [UnitId]
ociOriginalDeps :: [UnitId]
  }
  deriving (Int -> OriginalComponentInfo -> [Char] -> [Char]
[OriginalComponentInfo] -> [Char] -> [Char]
OriginalComponentInfo -> [Char]
(Int -> OriginalComponentInfo -> [Char] -> [Char])
-> (OriginalComponentInfo -> [Char])
-> ([OriginalComponentInfo] -> [Char] -> [Char])
-> Show OriginalComponentInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> OriginalComponentInfo -> [Char] -> [Char]
showsPrec :: Int -> OriginalComponentInfo -> [Char] -> [Char]
$cshow :: OriginalComponentInfo -> [Char]
show :: OriginalComponentInfo -> [Char]
$cshowList :: [OriginalComponentInfo] -> [Char] -> [Char]
showList :: [OriginalComponentInfo] -> [Char] -> [Char]
Show)

addDepsToProjectTarget
  :: [Dependency]
  -> PackageId
  -> ProjectBaseContext
  -> ProjectBaseContext
addDepsToProjectTarget :: [Dependency]
-> PackageIdentifier -> ProjectBaseContext -> ProjectBaseContext
addDepsToProjectTarget [Dependency]
deps PackageIdentifier
pkgId ProjectBaseContext
ctx =
  (\[PackageSpecifier UnresolvedSourcePackage]
p -> ProjectBaseContext
ctx{localPackages = p}) ([PackageSpecifier UnresolvedSourcePackage] -> ProjectBaseContext)
-> (ProjectBaseContext
    -> [PackageSpecifier UnresolvedSourcePackage])
-> ProjectBaseContext
-> ProjectBaseContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageSpecifier UnresolvedSourcePackage
 -> PackageSpecifier UnresolvedSourcePackage)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSpecifier UnresolvedSourcePackage
-> PackageSpecifier UnresolvedSourcePackage
addDeps ([PackageSpecifier UnresolvedSourcePackage]
 -> [PackageSpecifier UnresolvedSourcePackage])
-> (ProjectBaseContext
    -> [PackageSpecifier UnresolvedSourcePackage])
-> ProjectBaseContext
-> [PackageSpecifier UnresolvedSourcePackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages (ProjectBaseContext -> ProjectBaseContext)
-> ProjectBaseContext -> ProjectBaseContext
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
ctx
  where
    addDeps
      :: PackageSpecifier UnresolvedSourcePackage
      -> PackageSpecifier UnresolvedSourcePackage
    addDeps :: PackageSpecifier UnresolvedSourcePackage
-> PackageSpecifier UnresolvedSourcePackage
addDeps (SpecificSourcePackage UnresolvedSourcePackage
pkg)
      | UnresolvedSourcePackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId UnresolvedSourcePackage
pkg PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageIdentifier
pkgId = UnresolvedSourcePackage -> PackageSpecifier UnresolvedSourcePackage
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage UnresolvedSourcePackage
pkg
      | SourcePackage{PackageDescriptionOverride
PackageIdentifier
GenericPackageDescription
UnresolvedPkgLoc
srcpkgPackageId :: PackageIdentifier
srcpkgDescription :: GenericPackageDescription
srcpkgSource :: UnresolvedPkgLoc
srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgPackageId :: forall loc. SourcePackage loc -> PackageIdentifier
srcpkgDescription :: forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgSource :: forall loc. SourcePackage loc -> loc
srcpkgDescrOverride :: forall loc. SourcePackage loc -> PackageDescriptionOverride
..} <- UnresolvedSourcePackage
pkg =
          UnresolvedSourcePackage -> PackageSpecifier UnresolvedSourcePackage
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage (UnresolvedSourcePackage
 -> PackageSpecifier UnresolvedSourcePackage)
-> UnresolvedSourcePackage
-> PackageSpecifier UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$
            UnresolvedSourcePackage
pkg
              { srcpkgDescription =
                  -- New dependencies are added to the original ones found in the
                  -- `targetBuildDepends` field.
                  -- `traverseBuildInfos` is used in order to update _all_ the
                  -- occurrences of the field `targetBuildDepends`. It ensures that
                  -- fields depending on the latter are also consistently updated.
                  srcpkgDescription
                    & (L.traverseBuildInfos . L.targetBuildDepends)
                      %~ (deps ++)
              }
    addDeps PackageSpecifier UnresolvedSourcePackage
spec = PackageSpecifier UnresolvedSourcePackage
spec

generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String]
generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [[Char]]
generateReplFlags Bool
includeTransitive ElaboratedInstallPlan
elaboratedPlan OriginalComponentInfo{[UnitId]
UnitId
ociUnitId :: OriginalComponentInfo -> UnitId
ociOriginalDeps :: OriginalComponentInfo -> [UnitId]
ociUnitId :: UnitId
ociOriginalDeps :: [UnitId]
..} = [[Char]]
flags
  where
    exeDeps :: [UnitId]
    exeDeps :: [UnitId]
exeDeps =
      (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> [UnitId])
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [UnitId]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ((InstalledPackageInfo -> [UnitId])
-> (ElaboratedConfiguredPackage -> [UnitId])
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> [UnitId]
forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
InstallPlan.foldPlanPackage ([UnitId] -> InstalledPackageInfo -> [UnitId]
forall a b. a -> b -> a
const []) ElaboratedConfiguredPackage -> [UnitId]
elabOrderExeDependencies)
        (ElaboratedInstallPlan
-> [UnitId]
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.dependencyClosure ElaboratedInstallPlan
elaboratedPlan [UnitId
ociUnitId])

    deps, deps', trans, trans' :: [UnitId]
    flags :: [String]
    deps :: [UnitId]
deps = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> UnitId)
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [UnitId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElaboratedInstallPlan
-> UnitId
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.directDeps ElaboratedInstallPlan
elaboratedPlan UnitId
ociUnitId
    deps' :: [UnitId]
deps' = [UnitId]
deps [UnitId] -> [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
ociOriginalDeps
    trans :: [UnitId]
trans = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> UnitId)
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [UnitId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElaboratedInstallPlan
-> [UnitId]
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.dependencyClosure ElaboratedInstallPlan
elaboratedPlan [UnitId]
deps'
    trans' :: [UnitId]
trans' = [UnitId]
trans [UnitId] -> [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
ociOriginalDeps
    flags :: [[Char]]
flags =
      (UnitId -> [Char]) -> [UnitId] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Char]
"-package-id " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (UnitId -> [Char]) -> UnitId -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) ([UnitId] -> [[Char]])
-> ([UnitId] -> [UnitId]) -> [UnitId] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UnitId] -> [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
exeDeps) ([UnitId] -> [[Char]]) -> [UnitId] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
        if Bool
includeTransitive then [UnitId]
trans' else [UnitId]
deps'

-- | Add repl options to ensure the repl actually starts in the current working directory.
--
-- In a global or script context, when we are using a fake package, @cabal repl@
-- starts in the fake package directory instead of the directory it was called from,
-- so we need to tell ghci to change back to the correct directory.
--
-- The @-ghci-script@ flag is path to the ghci script responsible for changing to the
-- correct directory. Only works on GHC >= 7.6, though. 🙁
usingGhciScript :: Compiler -> FilePath -> ReplOptions -> IO ReplOptions
usingGhciScript :: Compiler -> [Char] -> ReplOptions -> IO ReplOptions
usingGhciScript Compiler
compiler [Char]
projectRoot ReplOptions
replOpts
  | CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC Compiler
compiler Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version -> Maybe Version
forall a. a -> Maybe a
Just Version
minGhciScriptVersion = do
      let ghciScriptPath :: [Char]
ghciScriptPath = [Char]
projectRoot [Char] -> [Char] -> [Char]
</> [Char]
"setcwd.ghci"
      [Char]
cwd <- IO [Char]
getCurrentDirectory
      [Char] -> [Char] -> IO ()
writeFile [Char]
ghciScriptPath ([Char]
":cd " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cwd)
      ReplOptions -> IO ReplOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReplOptions -> IO ReplOptions) -> ReplOptions -> IO ReplOptions
forall a b. (a -> b) -> a -> b
$ ReplOptions
replOpts ReplOptions -> (ReplOptions -> ReplOptions) -> ReplOptions
forall a b. a -> (a -> b) -> b
& LensLike Identity ReplOptions ReplOptions [[Char]] [[Char]]
Lens' ReplOptions [[Char]]
lReplOptionsFlags LensLike Identity ReplOptions ReplOptions [[Char]] [[Char]]
-> ([[Char]] -> [[Char]]) -> ReplOptions -> ReplOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (([Char]
"-ghci-script" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ghciScriptPath) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:)
  | Bool
otherwise = ReplOptions -> IO ReplOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ReplOptions
replOpts

-- | First version of GHC where GHCi supported the flag we need.
-- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html
minGhciScriptVersion :: Version
minGhciScriptVersion :: Version
minGhciScriptVersion = [Int] -> Version
mkVersion [Int
7, Int
6]

-- | This defines what a 'TargetSelector' means for the @repl@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For repl we select:
--
-- * the library if there is only one and it's buildable; or
--
-- * the exe if there is only one and it's buildable; or
--
-- * any other buildable component.
--
-- Fail if there are no buildable lib\/exe components, or if there are
-- multiple libs or exes.
selectPackageTargets
  :: MultiReplDecision
  -> TargetSelector
  -> [AvailableTarget k]
  -> Either ReplTargetProblem [k]
selectPackageTargets :: forall k.
MultiReplDecision
-> TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ReplProblem) [k]
selectPackageTargets MultiReplDecision
multiple_targets_allowed =
  -- If explicitly enabled, then select the targets like we would for multi-repl but
  -- might still fail later because of compiler version.
  if MultiReplDecision -> Bool
enabledByFlag MultiReplDecision
multiple_targets_allowed
    then TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k]
selectPackageTargetsMulti
    else MultiReplDecision
-> TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ReplProblem) [k]
forall k.
MultiReplDecision
-> TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ReplProblem) [k]
selectPackageTargetsSingle MultiReplDecision
multiple_targets_allowed

selectPackageTargetsMulti
  :: TargetSelector
  -> [AvailableTarget k]
  -> Either ReplTargetProblem [k]
selectPackageTargetsMulti :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k]
selectPackageTargetsMulti TargetSelector
targetSelector [AvailableTarget k]
targets
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable) =
      [k] -> Either (TargetProblem ReplProblem) [k]
forall a b. b -> Either a b
Right [k]
targetsBuildable
  -- If there are no targets at all then we report that
  | Bool
otherwise =
      TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem ReplProblem
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    ( [k]
targetsBuildable
      , [AvailableTarget ()]
_
      ) =
        (TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith'
          (TargetSelector -> TargetRequested -> Bool
isRequested TargetSelector
targetSelector)
          [AvailableTarget k]
targets

    -- When there's a target filter like "pkg:tests" then we do select tests,
    -- but if it's just a target like "pkg" then we don't build tests unless
    -- they are requested by default (i.e. by using --enable-tests)
    isRequested :: TargetSelector -> TargetRequested -> Bool
isRequested (TargetAllPackages Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    isRequested (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
_ Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    isRequested TargetSelector
_ TargetRequested
_ = Bool
True

-- | Target selection behaviour which only select a single target.
-- This is used when the compiler version doesn't support multi-repl or the user
-- didn't request it.
selectPackageTargetsSingle
  :: MultiReplDecision
  -> TargetSelector
  -> [AvailableTarget k]
  -> Either ReplTargetProblem [k]
selectPackageTargetsSingle :: forall k.
MultiReplDecision
-> TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ReplProblem) [k]
selectPackageTargetsSingle MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget k]
targets
  -- If there is exactly one buildable library then we select that
  | [k
target] <- [k]
targetsLibsBuildable =
      [k] -> Either (TargetProblem ReplProblem) [k]
forall a b. b -> Either a b
Right [k
target]
  -- but fail if there are multiple buildable libraries.
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsLibsBuildable) =
      TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
forall a b. a -> Either a b
Left (MultiReplDecision
-> TargetSelector
-> [AvailableTarget ()]
-> TargetProblem ReplProblem
matchesMultipleProblem MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget ()]
targetsLibsBuildable')
  -- If there is exactly one buildable executable then we select that
  | [k
target] <- [k]
targetsExesBuildable =
      [k] -> Either (TargetProblem ReplProblem) [k]
forall a b. b -> Either a b
Right [k
target]
  -- but fail if there are multiple buildable executables.
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsExesBuildable) =
      TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
forall a b. a -> Either a b
Left (MultiReplDecision
-> TargetSelector
-> [AvailableTarget ()]
-> TargetProblem ReplProblem
matchesMultipleProblem MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget ()]
targetsExesBuildable')
  -- If there is exactly one other target then we select that
  | [k
target] <- [k]
targetsBuildable =
      [k] -> Either (TargetProblem ReplProblem) [k]
forall a b. b -> Either a b
Right [k
target]
  -- but fail if there are multiple such targets
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable) =
      TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
forall a b. a -> Either a b
Left (MultiReplDecision
-> TargetSelector
-> [AvailableTarget ()]
-> TargetProblem ReplProblem
matchesMultipleProblem MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget ()]
targetsBuildable')
  -- If there are targets but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets) =
      TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem ReplProblem
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')
  -- If there are no targets at all then we report that
  | Bool
otherwise =
      TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem ReplProblem
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets' = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    ( [k]
targetsLibsBuildable
      , [AvailableTarget ()]
targetsLibsBuildable'
      ) =
        [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall k. [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets'
          ([AvailableTarget k] -> ([k], [AvailableTarget ()]))
-> ([AvailableTarget k] -> [AvailableTarget k])
-> [AvailableTarget k]
-> ([k], [AvailableTarget ()])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
LibKind
          ([AvailableTarget k] -> ([k], [AvailableTarget ()]))
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall a b. (a -> b) -> a -> b
$ [AvailableTarget k]
targets
    ( [k]
targetsExesBuildable
      , [AvailableTarget ()]
targetsExesBuildable'
      ) =
        [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall k. [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets'
          ([AvailableTarget k] -> ([k], [AvailableTarget ()]))
-> ([AvailableTarget k] -> [AvailableTarget k])
-> [AvailableTarget k]
-> ([k], [AvailableTarget ()])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
ExeKind
          ([AvailableTarget k] -> ([k], [AvailableTarget ()]))
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall a b. (a -> b) -> a -> b
$ [AvailableTarget k]
targets
    ( [k]
targetsBuildable
      , [AvailableTarget ()]
targetsBuildable'
      ) =
        (TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith'
          (TargetSelector -> TargetRequested -> Bool
isRequested TargetSelector
targetSelector)
          [AvailableTarget k]
targets

    -- When there's a target filter like "pkg:tests" then we do select tests,
    -- but if it's just a target like "pkg" then we don't build tests unless
    -- they are requested by default (i.e. by using --enable-tests)
    isRequested :: TargetSelector -> TargetRequested -> Bool
isRequested (TargetAllPackages Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    isRequested (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
_ Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    isRequested TargetSelector
_ TargetRequested
_ = Bool
True

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @repl@ command we just need the basic checks on being buildable etc.
selectComponentTarget
  :: SubComponentTarget
  -> AvailableTarget k
  -> Either ReplTargetProblem k
selectComponentTarget :: forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ReplProblem) k
selectComponentTarget = SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ReplProblem) k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic

data ReplProblem
  = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()]
  | -- | Multiple 'TargetSelector's match multiple targets
    TargetProblemMultipleTargets MultiReplDecision TargetsMap
  deriving (ReplProblem -> ReplProblem -> Bool
(ReplProblem -> ReplProblem -> Bool)
-> (ReplProblem -> ReplProblem -> Bool) -> Eq ReplProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplProblem -> ReplProblem -> Bool
== :: ReplProblem -> ReplProblem -> Bool
$c/= :: ReplProblem -> ReplProblem -> Bool
/= :: ReplProblem -> ReplProblem -> Bool
Eq, Int -> ReplProblem -> [Char] -> [Char]
[ReplProblem] -> [Char] -> [Char]
ReplProblem -> [Char]
(Int -> ReplProblem -> [Char] -> [Char])
-> (ReplProblem -> [Char])
-> ([ReplProblem] -> [Char] -> [Char])
-> Show ReplProblem
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ReplProblem -> [Char] -> [Char]
showsPrec :: Int -> ReplProblem -> [Char] -> [Char]
$cshow :: ReplProblem -> [Char]
show :: ReplProblem -> [Char]
$cshowList :: [ReplProblem] -> [Char] -> [Char]
showList :: [ReplProblem] -> [Char] -> [Char]
Show)

-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.
type ReplTargetProblem = TargetProblem ReplProblem

matchesMultipleProblem
  :: MultiReplDecision
  -> TargetSelector
  -> [AvailableTarget ()]
  -> ReplTargetProblem
matchesMultipleProblem :: MultiReplDecision
-> TargetSelector
-> [AvailableTarget ()]
-> TargetProblem ReplProblem
matchesMultipleProblem MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget ()]
targetsExesBuildable =
  ReplProblem -> TargetProblem ReplProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ReplProblem -> TargetProblem ReplProblem)
-> ReplProblem -> TargetProblem ReplProblem
forall a b. (a -> b) -> a -> b
$ MultiReplDecision
-> TargetSelector -> [AvailableTarget ()] -> ReplProblem
TargetProblemMatchesMultiple MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget ()]
targetsExesBuildable

multipleTargetsProblem
  :: MultiReplDecision
  -> TargetsMap
  -> ReplTargetProblem
multipleTargetsProblem :: MultiReplDecision -> TargetsMap -> TargetProblem ReplProblem
multipleTargetsProblem MultiReplDecision
decision = ReplProblem -> TargetProblem ReplProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ReplProblem -> TargetProblem ReplProblem)
-> (TargetsMap -> ReplProblem)
-> TargetsMap
-> TargetProblem ReplProblem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiReplDecision -> TargetsMap -> ReplProblem
TargetProblemMultipleTargets MultiReplDecision
decision

reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems :: forall a. Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems Verbosity
verbosity =
  Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a)
-> ([TargetProblem ReplProblem] -> CabalInstallException)
-> [TargetProblem ReplProblem]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> CabalInstallException
RenderReplTargetProblem ([[Char]] -> CabalInstallException)
-> ([TargetProblem ReplProblem] -> [[Char]])
-> [TargetProblem ReplProblem]
-> CabalInstallException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TargetProblem ReplProblem -> [Char])
-> [TargetProblem ReplProblem] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map TargetProblem ReplProblem -> [Char]
renderReplTargetProblem

renderReplTargetProblem :: TargetProblem ReplProblem -> String
renderReplTargetProblem :: TargetProblem ReplProblem -> [Char]
renderReplTargetProblem = [Char]
-> (ReplProblem -> [Char]) -> TargetProblem ReplProblem -> [Char]
forall a. [Char] -> (a -> [Char]) -> TargetProblem a -> [Char]
renderTargetProblem [Char]
"open a repl for" ReplProblem -> [Char]
renderReplProblem

renderReplProblem :: ReplProblem -> String
renderReplProblem :: ReplProblem -> [Char]
renderReplProblem (TargetProblemMatchesMultiple MultiReplDecision
decision TargetSelector
targetSelector [AvailableTarget ()]
targets) =
  [Char]
"Cannot open a repl for multiple components at once. The target '"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TargetSelector -> [Char]
showTargetSelector TargetSelector
targetSelector
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' refers to "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TargetSelector -> [Char]
renderTargetSelector TargetSelector
targetSelector
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" which "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if TargetSelector -> Bool
targetSelectorRefersToPkgs TargetSelector
targetSelector then [Char]
"includes " else [Char]
"are ")
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
renderListSemiAnd
      [ [Char]
"the "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Plural -> ComponentKind -> [Char]
renderComponentKind Plural
Plural ComponentKind
ckind
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
renderListCommaAnd
          [ [Char]
-> (UnqualComponentName -> [Char])
-> Maybe UnqualComponentName
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageName
pkgname) UnqualComponentName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (ComponentName -> Maybe UnqualComponentName
componentNameString ComponentName
cname)
          | AvailableTarget ()
t <- [AvailableTarget ()]
ts
          , let cname :: ComponentName
cname = AvailableTarget () -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget ()
t
                pkgname :: PackageName
pkgname = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName (AvailableTarget () -> PackageIdentifier
forall k. AvailableTarget k -> PackageIdentifier
availableTargetPackageId AvailableTarget ()
t)
          ]
      | (ComponentKind
ckind, [AvailableTarget ()]
ts) <- (AvailableTarget () -> ComponentKind)
-> [AvailableTarget ()] -> [(ComponentKind, [AvailableTarget ()])]
forall b a. Ord b => (a -> b) -> [a] -> [(b, [a])]
sortGroupOn AvailableTarget () -> ComponentKind
forall {k}. AvailableTarget k -> ComponentKind
availableTargetComponentKind [AvailableTarget ()]
targets
      ]
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".\n\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MultiReplDecision -> [Char]
explainMultiReplDecision MultiReplDecision
decision
  where
    availableTargetComponentKind :: AvailableTarget k -> ComponentKind
availableTargetComponentKind =
      ComponentName -> ComponentKind
componentKind
        (ComponentName -> ComponentKind)
-> (AvailableTarget k -> ComponentName)
-> AvailableTarget k
-> ComponentKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName
renderReplProblem (TargetProblemMultipleTargets MultiReplDecision
multi_decision TargetsMap
selectorMap) =
  [Char]
"Cannot open a repl for multiple components at once. The targets "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
renderListCommaAnd
      [ [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TargetSelector -> [Char]
showTargetSelector TargetSelector
ts [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
      | TargetSelector
ts <- TargetsMap -> [TargetSelector]
uniqueTargetSelectors TargetsMap
selectorMap
      ]
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" refer to different components."
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".\n\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MultiReplDecision -> [Char]
explainMultiReplDecision MultiReplDecision
multi_decision

explainMultiReplDecision :: MultiReplDecision -> [Char]
explainMultiReplDecision :: MultiReplDecision -> [Char]
explainMultiReplDecision MultiReplDecision{Maybe Version
compilerVersion :: MultiReplDecision -> Maybe Version
compilerVersion :: Maybe Version
compilerVersion, Bool
enabledByFlag :: MultiReplDecision -> Bool
enabledByFlag :: Bool
enabledByFlag} =
  case (Maybe Version
compilerVersion Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version -> Maybe Version
forall a. a -> Maybe a
Just Version
minMultipleHomeUnitsVersion, Bool
enabledByFlag) of
    -- Compiler not new enough, and not requested anyway.
    (Bool
False, Bool
False) -> Maybe Version -> [Char]
explanationSingleComponentLimitation Maybe Version
compilerVersion
    -- Compiler too old, but was requested
    (Bool
False, Bool
True) -> [Char]
"Multiple component session requested but compiler version is too old.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Version -> [Char]
explanationSingleComponentLimitation Maybe Version
compilerVersion
    -- Compiler new enough, but not requested
    (Bool
True, Bool
False) -> [Char]
explanationNeedToEnableFlag
    (Bool, Bool)
_ -> [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"explainMultiReplDecision"

explanationNeedToEnableFlag :: String
explanationNeedToEnableFlag :: [Char]
explanationNeedToEnableFlag =
  [Char]
"Your compiler supports a multiple component repl but support is not enabled.\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"The experimental multi repl can be enabled by\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  * Globally: Setting multi-repl: True in your .cabal/config\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  * Project Wide: Setting multi-repl: True in your cabal.project file\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  * Per Invocation: By passing --enable-multi-repl when starting the repl"

explanationSingleComponentLimitation :: Maybe Version -> String
explanationSingleComponentLimitation :: Maybe Version -> [Char]
explanationSingleComponentLimitation Maybe Version
version =
  [Char]
"The reason for this limitation is that your version "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
versionString
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"of ghci does not "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"support loading multiple components as source. Load just one component "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"and when you make changes to a dependent component then quit and reload.\n"
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
minMultipleHomeUnitsVersion
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is needed to support multiple component sessions."
  where
    versionString :: [Char]
versionString = case Maybe Version
version of
      Maybe Version
Nothing -> [Char]
""
      Just Version
ver -> [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
ver [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") "

-- Lenses
lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared ElaboratedSharedConfig -> f ElaboratedSharedConfig
f ProjectBuildContext
s = (ElaboratedSharedConfig -> ProjectBuildContext)
-> f ElaboratedSharedConfig -> f ProjectBuildContext
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ElaboratedSharedConfig
x -> ProjectBuildContext
s{elaboratedShared = x}) (ElaboratedSharedConfig -> f ElaboratedSharedConfig
f (ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared ProjectBuildContext
s))
{-# INLINE lElaboratedShared #-}

lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions
lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions
lPkgConfigReplOptions ReplOptions -> f ReplOptions
f ElaboratedSharedConfig
s = (ReplOptions -> ElaboratedSharedConfig)
-> f ReplOptions -> f ElaboratedSharedConfig
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ReplOptions
x -> ElaboratedSharedConfig
s{pkgConfigReplOptions = x}) (ReplOptions -> f ReplOptions
f (ElaboratedSharedConfig -> ReplOptions
pkgConfigReplOptions ElaboratedSharedConfig
s))
{-# INLINE lPkgConfigReplOptions #-}

lReplOptionsFlags :: Lens' ReplOptions [String]
lReplOptionsFlags :: Lens' ReplOptions [[Char]]
lReplOptionsFlags [[Char]] -> f [[Char]]
f ReplOptions
s = ([[Char]] -> ReplOptions) -> f [[Char]] -> f ReplOptions
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[[Char]]
x -> ReplOptions
s{replOptionsFlags = x}) ([[Char]] -> f [[Char]]
f (ReplOptions -> [[Char]]
replOptionsFlags ReplOptions
s))
{-# INLINE lReplOptionsFlags #-}

lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig ProjectConfig -> f ProjectConfig
f ProjectBaseContext
s = (ProjectConfig -> ProjectBaseContext)
-> f ProjectConfig -> f ProjectBaseContext
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ProjectConfig
x -> ProjectBaseContext
s{projectConfig = x}) (ProjectConfig -> f ProjectConfig
f (ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
s))
{-# INLINE lProjectConfig #-}

lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared
lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared
lProjectConfigShared ProjectConfigShared -> f ProjectConfigShared
f ProjectConfig
s = (ProjectConfigShared -> ProjectConfig)
-> f ProjectConfigShared -> f ProjectConfig
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ProjectConfigShared
x -> ProjectConfig
s{projectConfigShared = x}) (ProjectConfigShared -> f ProjectConfigShared
f (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
s))
{-# INLINE lProjectConfigShared #-}

lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]
lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]
lProjectConfigConstraints [(UserConstraint, ConstraintSource)]
-> f [(UserConstraint, ConstraintSource)]
f ProjectConfigShared
s = ([(UserConstraint, ConstraintSource)] -> ProjectConfigShared)
-> f [(UserConstraint, ConstraintSource)] -> f ProjectConfigShared
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[(UserConstraint, ConstraintSource)]
x -> ProjectConfigShared
s{projectConfigConstraints = x}) ([(UserConstraint, ConstraintSource)]
-> f [(UserConstraint, ConstraintSource)]
f (ProjectConfigShared -> [(UserConstraint, ConstraintSource)]
projectConfigConstraints ProjectConfigShared
s))
{-# INLINE lProjectConfigConstraints #-}