{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

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

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

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

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

import Distribution.Client.DistDirLayout
         ( DistDirLayout(..) )
import Distribution.Client.NixStyleOptions
         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.CmdErrorMessages
         ( renderTargetSelector, showTargetSelector,
           renderTargetProblem,
           targetSelectorRefersToPkgs,
           renderComponentKind, renderListCommaAnd, renderListSemiAnd,
           componentKind, sortGroupOn, Plural(..) )
import Distribution.Client.TargetProblem
         ( TargetProblem(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.ProjectBuilding
         ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
       ( ElaboratedSharedConfig(..), ElaboratedInstallPlan )
import Distribution.Client.ProjectPlanning.Types
       ( elabOrderExeDependencies )
import Distribution.Client.ScriptUtils
         ( AcceptNoTargets(..), withContextAndSelectors, TargetContext(..)
         , updateContextAndWriteProjectFile, updateContextAndWriteProjectFile'
         , fakeProjectSourcePackage, lSrcpkgDescription )
import Distribution.Client.Setup
         ( GlobalFlags, ConfigFlags(..) )
import qualified Distribution.Client.Setup as Client
import Distribution.Client.Types
         ( PackageSpecifier(..), UnresolvedSourcePackage )
import Distribution.Simple.Setup
         ( fromFlagOrDefault, ReplOptions(..), replOptions
         , Flag(..), toFlag, falseArg )
import Distribution.Simple.Command
         ( CommandUI(..), liftOptionL, usageAlternatives, option
         , ShowOrParseArgs, OptionField, reqArg )
import Distribution.Compiler
         ( CompilerFlavor(GHC) )
import Distribution.Simple.Compiler
         ( Compiler, compilerCompatVersion )
import Distribution.Package
         ( Package(..), packageName, UnitId, installedUnitId )
import Distribution.Parsec
         ( parsecCommaList )
import Distribution.ReadE
         ( ReadE, parsecToReadE )
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.Version
         ( Version, mkVersion )
import Distribution.Types.VersionRange
         ( anyVersion )
import Distribution.Utils.Generic
         ( safeHead )
import Distribution.Verbosity
         ( normal, lessVerbose )
import Distribution.Simple.Utils
         ( wrapText, die', debugNoWrap )
import Language.Haskell.Extension
         ( Language(..) )

import Data.List
         ( (\\) )
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.Directory
         ( doesFileExist, getCurrentDirectory )
import System.FilePath
         ( (</>) )

data EnvFlags = EnvFlags
  { EnvFlags -> [Dependency]
envPackages :: [Dependency]
  , EnvFlags -> Flag Bool
envIncludeTransitive :: Flag Bool
  }

defaultEnvFlags :: EnvFlags
defaultEnvFlags :: EnvFlags
defaultEnvFlags = EnvFlags
  { envPackages :: [Dependency]
envPackages = []
  , envIncludeTransitive :: Flag Bool
envIncludeTransitive = forall a. a -> Flag a
toFlag Bool
True
  }

envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions ShowOrParseArgs
_ =
  [ forall get set a.
[Char]
-> LFlags
-> [Char]
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [Char
'b'] [[Char]
"build-depends"]
    [Char]
"Include additional packages in the environment presented to GHCi."
    EnvFlags -> [Dependency]
envPackages (\[Dependency]
p EnvFlags
flags -> EnvFlags
flags { envPackages :: [Dependency]
envPackages = [Dependency]
p forall a. [a] -> [a] -> [a]
++ EnvFlags -> [Dependency]
envPackages EnvFlags
flags })
    (forall b a.
Monoid b =>
[Char]
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg [Char]
"DEPENDENCIES" ReadE [Dependency]
dependenciesReadE (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Pretty a => a -> [Char]
prettyShow :: [Dependency] -> [String]))
  , forall get set a.
[Char]
-> LFlags
-> [Char]
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [] [[Char]
"no-transitive-deps"]
    [Char]
"Don't automatically include transitive dependencies of requested packages."
    EnvFlags -> Flag Bool
envIncludeTransitive (\Flag Bool
p EnvFlags
flags -> EnvFlags
flags { envIncludeTransitive :: Flag Bool
envIncludeTransitive = Flag Bool
p })
    forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
falseArg
  ]
  where
    dependenciesReadE :: ReadE [Dependency]
    dependenciesReadE :: ReadE [Dependency]
dependenciesReadE =
      forall a. ([Char] -> [Char]) -> ParsecParser a -> ReadE a
parsecToReadE
        ([Char]
"couldn't parse dependencies: " forall a. [a] -> [a] -> [a]
++)
        (forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecCommaList forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec)

replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags))
replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags))
replCommand = CommandUI
  (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
   BenchmarkFlags)
Client.installCommand {
  commandName :: [Char]
commandName         = [Char]
"v2-repl",
  commandSynopsis :: [Char]
commandSynopsis     = [Char]
"Open an interactive session for the given component.",
  commandUsage :: [Char] -> [Char]
commandUsage        = [Char] -> LFlags -> [Char] -> [Char]
usageAlternatives [Char]
"v2-repl" [ [Char]
"[TARGET] [FLAGS]" ],
  commandDescription :: Maybe ([Char] -> [Char])
commandDescription  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \[Char]
_ -> [Char] -> [Char]
wrapText forall a b. (a -> b) -> a -> b
$
        [Char]
"Open an interactive session for a component within the project. The "
     forall a. [a] -> [a] -> [a]
++ [Char]
"available targets are the same as for the 'v2-build' command: "
     forall a. [a] -> [a] -> [a]
++ [Char]
"individual components within packages in the project, including "
     forall a. [a] -> [a] -> [a]
++ [Char]
"libraries, executables, test-suites or benchmarks. Packages can "
     forall a. [a] -> [a] -> [a]
++ [Char]
"also be specified in which case the library component in the "
     forall a. [a] -> [a] -> [a]
++ [Char]
"package will be used, or the (first listed) executable in the "
     forall a. [a] -> [a] -> [a]
++ [Char]
"package if there is no library.\n\n"

     forall a. [a] -> [a] -> [a]
++ [Char]
"Dependencies are built or rebuilt as necessary. Additional "
     forall a. [a] -> [a] -> [a]
++ [Char]
"configuration flags can be specified on the command line and these "
     forall a. [a] -> [a] -> [a]
++ [Char]
"extend the project configuration from the 'cabal.project', "
     forall a. [a] -> [a] -> [a]
++ [Char]
"'cabal.project.local' and other files.",
  commandNotes :: Maybe ([Char] -> [Char])
commandNotes        = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \[Char]
pname ->
        [Char]
"Examples, open an interactive session:\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    for the default component in the package in the current directory\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl pkgname\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    for the default component in the package named 'pkgname'\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl ./pkgfoo\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    for the default component in the package in the ./pkgfoo directory\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl cname\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    for the component named 'cname'\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl pkgname:cname\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    for the component 'cname' in the package 'pkgname'\n\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl --build-depends lens\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    add the latest version of the library 'lens' to the default component "
        forall a. [a] -> [a] -> [a]
++ [Char]
"(or no componentif there is no project present)\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
" v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
     forall a. [a] -> [a] -> [a]
++ [Char]
"    add a version (constrained between 4.15 and 4.18) of the library 'lens' "
        forall a. [a] -> [a] -> [a]
++ [Char]
"to the default component (or no component if there is no project present)\n",

  commandDefaultFlags :: NixStyleFlags (ReplOptions, EnvFlags)
commandDefaultFlags = forall a. a -> NixStyleFlags a
defaultNixStyleFlags (forall a. Monoid a => a
mempty, EnvFlags
defaultEnvFlags),
  commandOptions :: ShowOrParseArgs
-> [OptionField (NixStyleFlags (ReplOptions, EnvFlags))]
commandOptions = forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions forall a b. (a -> b) -> a -> b
$ \ShowOrParseArgs
showOrParseArgs ->
    forall a b. (a -> b) -> [a] -> [b]
map (forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL forall a c b. Lens (a, c) (b, c) a b
_1) (ShowOrParseArgs -> [OptionField ReplOptions]
replOptions ShowOrParseArgs
showOrParseArgs) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL forall c a b. Lens (c, a) (c, b) a b
_2) (ShowOrParseArgs -> [OptionField EnvFlags]
envOptions ShowOrParseArgs
showOrParseArgs)
  }

-- | 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 only one target is allowed
-- (given or implicit) 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 (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO ()
replAction :: NixStyleFlags (ReplOptions, EnvFlags)
-> LFlags -> GlobalFlags -> IO ()
replAction flags :: NixStyleFlags (ReplOptions, EnvFlags)
flags@NixStyleFlags { extraFlags :: forall a. NixStyleFlags a -> a
extraFlags = (ReplOptions
replOpts, EnvFlags
envFlags), ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} LFlags
targetStrings GlobalFlags
globalFlags
  = forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> LFlags
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
AcceptNoTargets (forall a. a -> Maybe a
Just ComponentKind
LibKind) NixStyleFlags (ReplOptions, EnvFlags)
flags LFlags
targetStrings GlobalFlags
globalFlags CurrentCommand
ReplCommand forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
ctx)) forall a b. (a -> b) -> a -> b
$
      forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"The repl command does not support '--only-dependencies'. "
          forall a. [a] -> [a] -> [a]
++ [Char]
"You may wish to use 'build --only-dependencies' and then "
          forall a. [a] -> [a] -> [a]
++ [Char]
"use 'repl'."

    let projectRoot :: [Char]
projectRoot = DistDirLayout -> [Char]
distProjectRootDirectory forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx

    ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      TargetContext
GlobalContext  -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
targetStrings) forall a b. (a -> b) -> a -> b
$
          forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"'repl' takes no arguments or a script argument outside a project: " forall a. [a] -> [a] -> [a]
++ LFlags -> [Char]
unwords LFlags
targetStrings

        let
          sourcePackage :: SourcePackage (PackageLocation loc)
sourcePackage = forall loc. [Char] -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage [Char]
projectRoot
            forall a b. a -> (a -> b) -> b
& forall loc. Lens' (SourcePackage loc) GenericPackageDescription
lSrcpkgDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  GenericPackageDescription
  (Maybe (CondTree ConfVar [Dependency] Library))
L.condLibrary
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (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 :: BuildInfo
libBuildInfo = BuildInfo
lBuildInfo }
          lBuildInfo :: BuildInfo
lBuildInfo = BuildInfo
emptyBuildInfo
            { targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency
baseDep]
            , defaultLanguage :: Maybe Language
defaultLanguage = forall a. a -> Maybe a
Just Language
Haskell2010
            }
          baseDep :: Dependency
baseDep = PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
"base" VersionRange
anyVersion NonEmptySet LibraryName
mainLibSet

        ProjectBaseContext
-> UnresolvedSourcePackage -> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx forall {loc}. SourcePackage (PackageLocation loc)
sourcePackage
      ScriptContext [Char]
scriptPath Executable
scriptExecutable -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length LFlags
targetStrings forall a. Eq a => a -> a -> Bool
== Int
1) forall a b. (a -> b) -> a -> b
$
          forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"'repl' takes a single argument which should be a script: " forall a. [a] -> [a] -> [a]
++ LFlags -> [Char]
unwords LFlags
targetStrings
        Bool
existsScriptPath <- [Char] -> IO Bool
doesFileExist [Char]
scriptPath
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
existsScriptPath forall a b. (a -> b) -> a -> b
$
          forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"'repl' takes a single argument which should be a script: " forall a. [a] -> [a] -> [a]
++ LFlags -> [Char]
unwords LFlags
targetStrings

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

    (Maybe OriginalComponentInfo
originalComponent, ProjectBaseContext
baseCtx') <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EnvFlags -> [Dependency]
envPackages EnvFlags
envFlags)
      then forall (m :: * -> *) a. Monad m => a -> m a
return (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.
        forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan (Verbosity -> Verbosity
lessVerbose Verbosity
verbosity) ProjectBaseContext
baseCtx forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
_ -> do
          -- targets should be non-empty map, but there's no NonEmptyMap yet.
          TargetsMap
targets <- ElaboratedInstallPlan -> [TargetSelector] -> IO TargetsMap
validatedTargets ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors

          let
            (UnitId
unitId, [(ComponentTarget, NonEmpty TargetSelector)]
_) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"panic: targets should be non-empty") forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
safeHead forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList TargetsMap
targets
            originalDeps :: [UnitId]
originalDeps = forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"cannot find " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow UnitId
unitId) forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => pkg -> PackageIdentifier
packageId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
envFlags) PackageIdentifier
pkgId ProjectBaseContext
baseCtx

          forall (m :: * -> *) a. Monad m => a -> m a
return (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') <- forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan Verbosity
verbosity ProjectBaseContext
baseCtx' forall a b. (a -> b) -> a -> b
$
      \ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
elaboratedShared' -> do
        let ProjectBaseContext{[PackageSpecifier UnresolvedSourcePackage]
Maybe InstalledPackageIndex
BuildTimeSettings
ProjectConfig
CabalDirLayout
DistDirLayout
CurrentCommand
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
currentCommand :: ProjectBaseContext -> CurrentCommand
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectBaseContext -> ProjectConfig
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
installedPackages :: Maybe InstalledPackageIndex
currentCommand :: CurrentCommand
buildSettings :: BuildTimeSettings
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectConfig
cabalDirLayout :: CabalDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
buildSettings :: ProjectBaseContext -> BuildTimeSettings
..} = ProjectBaseContext
baseCtx'

        -- Recalculate with updated project.
        TargetsMap
targets <- ElaboratedInstallPlan -> [TargetSelector] -> IO TargetsMap
validatedTargets ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors

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

        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 (forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> [Char]
InstallPlan.showInstallPlan 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'

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

        forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBuildContext
buildCtx, Compiler
compiler, ReplOptions
replOpts forall a b. a -> (a -> b) -> b
& Lens' ReplOptions LFlags
lReplOptionsFlags forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ LFlags
replFlags))

    ReplOptions
replOpts'' <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> 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 forall a b. a -> (a -> b) -> b
& Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ElaboratedSharedConfig ReplOptions
lPkgConfigReplOptions 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
    verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)

    validatedTargets :: ElaboratedInstallPlan -> [TargetSelector] -> IO TargetsMap
validatedTargets ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors = do
      -- Interpret the targets on the command line as repl targets
      -- (as opposed to say build or haddock targets).
      TargetsMap
targets <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return
          forall a b. (a -> b) -> a -> b
$ 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
              forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k]
selectPackageTargets
              forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ReplProblem) k
selectComponentTarget
              ElaboratedInstallPlan
elaboratedPlan
              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.
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Set a -> Int
Set.size (TargetsMap -> Set (UnitId, ComponentName)
distinctTargetComponents TargetsMap
targets) forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
        forall a. Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems Verbosity
verbosity
          [TargetsMap -> TargetProblem ReplProblem
multipleTargetsProblem TargetsMap
targets]

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

data OriginalComponentInfo = OriginalComponentInfo
  { OriginalComponentInfo -> UnitId
ociUnitId :: UnitId
  , OriginalComponentInfo -> [UnitId]
ociOriginalDeps :: [UnitId]
  }
  deriving (Int -> OriginalComponentInfo -> [Char] -> [Char]
[OriginalComponentInfo] -> [Char] -> [Char]
OriginalComponentInfo -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [OriginalComponentInfo] -> [Char] -> [Char]
$cshowList :: [OriginalComponentInfo] -> [Char] -> [Char]
show :: OriginalComponentInfo -> [Char]
$cshow :: OriginalComponentInfo -> [Char]
showsPrec :: Int -> OriginalComponentInfo -> [Char] -> [Char]
$cshowsPrec :: Int -> 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 :: [PackageSpecifier UnresolvedSourcePackage]
localPackages = [PackageSpecifier UnresolvedSourcePackage]
p }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSpecifier UnresolvedSourcePackage
-> PackageSpecifier UnresolvedSourcePackage
addDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
ctx
  where
    addDeps :: PackageSpecifier UnresolvedSourcePackage
            -> PackageSpecifier UnresolvedSourcePackage
    addDeps :: PackageSpecifier UnresolvedSourcePackage
-> PackageSpecifier UnresolvedSourcePackage
addDeps (SpecificSourcePackage UnresolvedSourcePackage
pkg)
      | forall pkg. Package pkg => pkg -> PackageIdentifier
packageId UnresolvedSourcePackage
pkg forall a. Eq a => a -> a -> Bool
/= PackageIdentifier
pkgId = forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage UnresolvedSourcePackage
pkg
      | SourcePackage{PackageDescriptionOverride
GenericPackageDescription
PackageIdentifier
UnresolvedPkgLoc
srcpkgPackageId :: forall loc. SourcePackage loc -> PackageIdentifier
srcpkgDescription :: forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgSource :: forall loc. SourcePackage loc -> loc
srcpkgDescrOverride :: forall loc. SourcePackage loc -> PackageDescriptionOverride
srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgSource :: UnresolvedPkgLoc
srcpkgDescription :: GenericPackageDescription
srcpkgPackageId :: PackageIdentifier
..} <- UnresolvedSourcePackage
pkg =
        forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage forall a b. (a -> b) -> a -> b
$ UnresolvedSourcePackage
pkg { srcpkgDescription :: GenericPackageDescription
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.
          GenericPackageDescription
srcpkgDescription forall a b. a -> (a -> b) -> b
&  (forall a. HasBuildInfos a => Traversal' a BuildInfo
L.traverseBuildInfos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasBuildInfo a => Lens' a [Dependency]
L.targetBuildDepends)
                            forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Dependency]
deps forall a. [a] -> [a] -> [a]
++)
        }
    addDeps PackageSpecifier UnresolvedSourcePackage
spec = PackageSpecifier UnresolvedSourcePackage
spec

generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String]
generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> LFlags
generateReplFlags Bool
includeTransitive ElaboratedInstallPlan
elaboratedPlan OriginalComponentInfo{[UnitId]
UnitId
ociOriginalDeps :: [UnitId]
ociUnitId :: UnitId
ociOriginalDeps :: OriginalComponentInfo -> [UnitId]
ociUnitId :: OriginalComponentInfo -> UnitId
..} = LFlags
flags
  where
    exeDeps :: [UnitId]
    exeDeps :: [UnitId]
exeDeps =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        (forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
InstallPlan.foldPlanPackage (forall a b. a -> b -> a
const []) ElaboratedConfiguredPackage -> [UnitId]
elabOrderExeDependencies)
        (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   = forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.directDeps ElaboratedInstallPlan
elaboratedPlan UnitId
ociUnitId
    deps' :: [UnitId]
deps'  = [UnitId]
deps forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
ociOriginalDeps
    trans :: [UnitId]
trans  = forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.dependencyClosure ElaboratedInstallPlan
elaboratedPlan [UnitId]
deps'
    trans' :: [UnitId]
trans' = [UnitId]
trans forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
ociOriginalDeps
    flags :: LFlags
flags  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Char]
"-package-id " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
prettyShow) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
exeDeps)
      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 forall a. Ord a => a -> a -> Bool
>= 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 " forall a. [a] -> [a] -> [a]
++ [Char]
cwd)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ReplOptions
replOpts forall a b. a -> (a -> b) -> b
& Lens' ReplOptions LFlags
lReplOptionsFlags forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (([Char]
"-ghci-script" forall a. [a] -> [a] -> [a]
++ [Char]
ghciScriptPath) forall a. a -> [a] -> [a]
:)
  | Bool
otherwise = 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  :: TargetSelector
                      -> [AvailableTarget k] -> Either ReplTargetProblem [k]
selectPackageTargets :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets

    -- If there is exactly one buildable library then we select that
  | [k
target] <- [k]
targetsLibsBuildable
  = forall a b. b -> Either a b
Right [k
target]

    -- but fail if there are multiple buildable libraries.
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsLibsBuildable)
  = forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem ReplProblem
matchesMultipleProblem TargetSelector
targetSelector [AvailableTarget ()]
targetsLibsBuildable')

    -- If there is exactly one buildable executable then we select that
  | [k
target] <- [k]
targetsExesBuildable
  = forall a b. b -> Either a b
Right [k
target]

    -- but fail if there are multiple buildable executables.
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsExesBuildable)
  = forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem ReplProblem
matchesMultipleProblem TargetSelector
targetSelector [AvailableTarget ()]
targetsExesBuildable')

    -- If there is exactly one other target then we select that
  | [k
target] <- [k]
targetsBuildable
  = forall a b. b -> Either a b
Right [k
target]

    -- but fail if there are multiple such targets
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable)
  = forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem ReplProblem
matchesMultipleProblem TargetSelector
targetSelector [AvailableTarget ()]
targetsBuildable')

    -- If there are targets but none are buildable then we report those
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets)
  = forall a b. a -> Either a b
Left (forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')

    -- If there are no targets at all then we report that
  | Bool
otherwise
  = forall a b. a -> Either a b
Left (forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets'                = forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    ([k]
targetsLibsBuildable,
     [AvailableTarget ()]
targetsLibsBuildable') = forall k. [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets'
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
LibKind
                            forall a b. (a -> b) -> a -> b
$ [AvailableTarget k]
targets
    ([k]
targetsExesBuildable,
     [AvailableTarget ()]
targetsExesBuildable') = forall k. [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets'
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
ExeKind
                            forall a b. (a -> b) -> a -> b
$ [AvailableTarget k]
targets
    ([k]
targetsBuildable,
     [AvailableTarget ()]
targetsBuildable')     = 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 = forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic


data ReplProblem
  = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]

    -- | Multiple 'TargetSelector's match multiple targets
  | TargetProblemMultipleTargets TargetsMap
  deriving (ReplProblem -> ReplProblem -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReplProblem -> ReplProblem -> Bool
$c/= :: ReplProblem -> ReplProblem -> Bool
== :: ReplProblem -> ReplProblem -> Bool
$c== :: ReplProblem -> ReplProblem -> Bool
Eq, Int -> ReplProblem -> [Char] -> [Char]
[ReplProblem] -> [Char] -> [Char]
ReplProblem -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ReplProblem] -> [Char] -> [Char]
$cshowList :: [ReplProblem] -> [Char] -> [Char]
show :: ReplProblem -> [Char]
$cshow :: ReplProblem -> [Char]
showsPrec :: Int -> ReplProblem -> [Char] -> [Char]
$cshowsPrec :: Int -> 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
  :: TargetSelector
  -> [AvailableTarget ()]
  -> ReplTargetProblem
matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> TargetProblem ReplProblem
matchesMultipleProblem TargetSelector
targetSelector [AvailableTarget ()]
targetsExesBuildable =
  forall a. a -> TargetProblem a
CustomTargetProblem forall a b. (a -> b) -> a -> b
$ TargetSelector -> [AvailableTarget ()] -> ReplProblem
TargetProblemMatchesMultiple TargetSelector
targetSelector [AvailableTarget ()]
targetsExesBuildable

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

reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems :: forall a. Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems Verbosity
verbosity =
    forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. LFlags -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map TargetProblem ReplProblem -> [Char]
renderReplTargetProblem

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

renderReplProblem (TargetProblemMultipleTargets TargetsMap
selectorMap) =
    [Char]
"Cannot open a repl for multiple components at once. The targets "
 forall a. [a] -> [a] -> [a]
++ LFlags -> [Char]
renderListCommaAnd
      [ [Char]
"'" forall a. [a] -> [a] -> [a]
++ TargetSelector -> [Char]
showTargetSelector TargetSelector
ts forall a. [a] -> [a] -> [a]
++ [Char]
"'"
      | TargetSelector
ts <- TargetsMap -> [TargetSelector]
uniqueTargetSelectors TargetsMap
selectorMap ]
 forall a. [a] -> [a] -> [a]
++ [Char]
" refer to different components."
 forall a. [a] -> [a] -> [a]
++ [Char]
".\n\n" forall a. [a] -> [a] -> [a]
++ [Char]
explanationSingleComponentLimitation

explanationSingleComponentLimitation :: String
explanationSingleComponentLimitation :: [Char]
explanationSingleComponentLimitation =
    [Char]
"The reason for this limitation is that current versions of ghci do not "
 forall a. [a] -> [a] -> [a]
++ [Char]
"support loading multiple components as source. Load just one component "
 forall a. [a] -> [a] -> [a]
++ [Char]
"and when you make changes to a dependent component then quit and reload."

-- Lenses
lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared ElaboratedSharedConfig -> f ElaboratedSharedConfig
f ProjectBuildContext
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ElaboratedSharedConfig
x -> ProjectBuildContext
s { elaboratedShared :: ElaboratedSharedConfig
elaboratedShared = ElaboratedSharedConfig
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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ReplOptions
x -> ElaboratedSharedConfig
s { pkgConfigReplOptions :: ReplOptions
pkgConfigReplOptions = ReplOptions
x }) (ReplOptions -> f ReplOptions
f (ElaboratedSharedConfig -> ReplOptions
pkgConfigReplOptions ElaboratedSharedConfig
s))
{-# inline lPkgConfigReplOptions #-}

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