{-# 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(..), traverseCondTreeC )
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 :: [Dependency] -> Flag Bool -> EnvFlags
EnvFlags
  { envPackages :: [Dependency]
envPackages = []
  , envIncludeTransitive :: Flag Bool
envIncludeTransitive = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
True
  }

envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions ShowOrParseArgs
_ =
  [ SFlags
-> LFlags
-> SFlags
-> (EnvFlags -> [Dependency])
-> ([Dependency] -> EnvFlags -> EnvFlags)
-> MkOptDescr
     (EnvFlags -> [Dependency])
     ([Dependency] -> EnvFlags -> EnvFlags)
     EnvFlags
-> OptionField EnvFlags
forall get set a.
SFlags
-> LFlags
-> SFlags
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [Char
'b'] [SFlags
"build-depends"]
    SFlags
"Include additional packages in the environment presented to GHCi."
    EnvFlags -> [Dependency]
envPackages (\[Dependency]
p EnvFlags
flags -> EnvFlags
flags { envPackages :: [Dependency]
envPackages = [Dependency]
p [Dependency] -> [Dependency] -> [Dependency]
forall a. [a] -> [a] -> [a]
++ EnvFlags -> [Dependency]
envPackages EnvFlags
flags })
    (SFlags
-> ReadE [Dependency]
-> ([Dependency] -> LFlags)
-> MkOptDescr
     (EnvFlags -> [Dependency])
     ([Dependency] -> EnvFlags -> EnvFlags)
     EnvFlags
forall b a.
Monoid b =>
SFlags
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg SFlags
"DEPENDENCIES" ReadE [Dependency]
dependenciesReadE ((Dependency -> SFlags) -> [Dependency] -> LFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dependency -> SFlags
forall a. Pretty a => a -> SFlags
prettyShow :: [Dependency] -> [String]))
  , SFlags
-> LFlags
-> SFlags
-> (EnvFlags -> Flag Bool)
-> (Flag Bool -> EnvFlags -> EnvFlags)
-> MkOptDescr
     (EnvFlags -> Flag Bool)
     (Flag Bool -> EnvFlags -> EnvFlags)
     EnvFlags
-> OptionField EnvFlags
forall get set a.
SFlags
-> LFlags
-> SFlags
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option [] [SFlags
"no-transitive-deps"]
    SFlags
"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 })
    MkOptDescr
  (EnvFlags -> Flag Bool)
  (Flag Bool -> EnvFlags -> EnvFlags)
  EnvFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
falseArg
  ]
  where
    dependenciesReadE :: ReadE [Dependency]
    dependenciesReadE :: ReadE [Dependency]
dependenciesReadE =
      (SFlags -> SFlags)
-> ParsecParser [Dependency] -> ReadE [Dependency]
forall a. (SFlags -> SFlags) -> ParsecParser a -> ReadE a
parsecToReadE
        (SFlags
"couldn't parse dependencies: " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++)
        (ParsecParser Dependency -> ParsecParser [Dependency]
forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecCommaList ParsecParser Dependency
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 :: SFlags
commandName         = SFlags
"v2-repl",
  commandSynopsis :: SFlags
commandSynopsis     = SFlags
"Open an interactive session for the given component.",
  commandUsage :: SFlags -> SFlags
commandUsage        = SFlags -> LFlags -> SFlags -> SFlags
usageAlternatives SFlags
"v2-repl" [ SFlags
"[TARGET] [FLAGS]" ],
  commandDescription :: Maybe (SFlags -> SFlags)
commandDescription  = (SFlags -> SFlags) -> Maybe (SFlags -> SFlags)
forall a. a -> Maybe a
Just ((SFlags -> SFlags) -> Maybe (SFlags -> SFlags))
-> (SFlags -> SFlags) -> Maybe (SFlags -> SFlags)
forall a b. (a -> b) -> a -> b
$ \SFlags
_ -> SFlags -> SFlags
wrapText (SFlags -> SFlags) -> SFlags -> SFlags
forall a b. (a -> b) -> a -> b
$
        SFlags
"Open an interactive session for a component within the project. The "
     SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"available targets are the same as for the 'v2-build' command: "
     SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"individual components within packages in the project, including "
     SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"libraries, executables, test-suites or benchmarks. Packages can "
     SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"also be specified in which case the library component in the "
     SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"package will be used, or the (first listed) executable in the "
     SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"package if there is no library.\n\n"

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

  commandDefaultFlags :: NixStyleFlags (ReplOptions, EnvFlags)
commandDefaultFlags = (ReplOptions, EnvFlags) -> NixStyleFlags (ReplOptions, EnvFlags)
forall a. a -> NixStyleFlags a
defaultNixStyleFlags (ReplOptions
forall a. Monoid a => a
mempty, EnvFlags
defaultEnvFlags),
  commandOptions :: ShowOrParseArgs
-> [OptionField (NixStyleFlags (ReplOptions, EnvFlags))]
commandOptions = (ShowOrParseArgs -> [OptionField (ReplOptions, EnvFlags)])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags (ReplOptions, EnvFlags))]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ((ShowOrParseArgs -> [OptionField (ReplOptions, EnvFlags)])
 -> ShowOrParseArgs
 -> [OptionField (NixStyleFlags (ReplOptions, EnvFlags))])
-> (ShowOrParseArgs -> [OptionField (ReplOptions, EnvFlags)])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags (ReplOptions, EnvFlags))]
forall a b. (a -> b) -> a -> b
$ \ShowOrParseArgs
showOrParseArgs ->
    (OptionField ReplOptions -> OptionField (ReplOptions, EnvFlags))
-> [OptionField ReplOptions]
-> [OptionField (ReplOptions, EnvFlags)]
forall a b. (a -> b) -> [a] -> [b]
map (ALens' (ReplOptions, EnvFlags) ReplOptions
-> OptionField ReplOptions -> OptionField (ReplOptions, EnvFlags)
forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL ALens' (ReplOptions, EnvFlags) ReplOptions
forall a c b. Lens (a, c) (b, c) a b
_1) (ShowOrParseArgs -> [OptionField ReplOptions]
replOptions ShowOrParseArgs
showOrParseArgs) [OptionField (ReplOptions, EnvFlags)]
-> [OptionField (ReplOptions, EnvFlags)]
-> [OptionField (ReplOptions, EnvFlags)]
forall a. [a] -> [a] -> [a]
++
    (OptionField EnvFlags -> OptionField (ReplOptions, EnvFlags))
-> [OptionField EnvFlags] -> [OptionField (ReplOptions, EnvFlags)]
forall a b. (a -> b) -> [a] -> [b]
map (ALens' (ReplOptions, EnvFlags) EnvFlags
-> OptionField EnvFlags -> OptionField (ReplOptions, EnvFlags)
forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL ALens' (ReplOptions, EnvFlags) EnvFlags
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
  = AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags (ReplOptions, EnvFlags)
-> LFlags
-> GlobalFlags
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> LFlags
-> GlobalFlags
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
AcceptNoTargets (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
LibKind) NixStyleFlags (ReplOptions, EnvFlags)
flags LFlags
targetStrings GlobalFlags
globalFlags ((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 -> SFlags -> IO ()
forall a. Verbosity -> SFlags -> IO a
die' Verbosity
verbosity (SFlags -> IO ()) -> SFlags -> IO ()
forall a b. (a -> b) -> a -> b
$ SFlags
"The repl command does not support '--only-dependencies'. "
          SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"You may wish to use 'build --only-dependencies' and then "
          SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"use 'repl'."

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

    ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> ProjectBaseContext -> IO ProjectBaseContext
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 (LFlags -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
targetStrings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> SFlags -> IO ()
forall a. Verbosity -> SFlags -> IO a
die' Verbosity
verbosity (SFlags -> IO ()) -> SFlags -> IO ()
forall a b. (a -> b) -> a -> b
$ SFlags
"'repl' takes no arguments or a script argument outside a project: " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ LFlags -> SFlags
unwords LFlags
targetStrings

        let
          sourcePackage :: SourcePackage (PackageLocation loc)
sourcePackage = SFlags -> SourcePackage (PackageLocation loc)
forall loc. SFlags -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage SFlags
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. Lens' (SourcePackage loc) 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 :: BuildInfo
libBuildInfo = BuildInfo
lBuildInfo }
          lBuildInfo :: BuildInfo
lBuildInfo = BuildInfo
emptyBuildInfo
            { targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency
baseDep]
            , defaultLanguage :: Maybe Language
defaultLanguage = Language -> Maybe Language
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
-> SourcePackage (PackageLocation (Maybe SFlags))
-> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx SourcePackage (PackageLocation (Maybe SFlags))
forall loc. SourcePackage (PackageLocation loc)
sourcePackage
      ScriptContext SFlags
scriptPath Executable
scriptExecutable -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LFlags -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LFlags
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 -> SFlags -> IO ()
forall a. Verbosity -> SFlags -> IO a
die' Verbosity
verbosity (SFlags -> IO ()) -> SFlags -> IO ()
forall a b. (a -> b) -> a -> b
$ SFlags
"'repl' takes a single argument which should be a script: " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ LFlags -> SFlags
unwords LFlags
targetStrings
        Bool
existsScriptPath <- SFlags -> IO Bool
doesFileExist SFlags
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 -> SFlags -> IO ()
forall a. Verbosity -> SFlags -> IO a
die' Verbosity
verbosity (SFlags -> IO ()) -> SFlags -> IO ()
forall a b. (a -> b) -> a -> b
$ SFlags
"'repl' takes a single argument which should be a script: " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ LFlags -> SFlags
unwords LFlags
targetStrings

        ProjectBaseContext -> SFlags -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx SFlags
scriptPath Executable
scriptExecutable

    (Maybe OriginalComponentInfo
originalComponent, ProjectBaseContext
baseCtx') <- if [Dependency] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EnvFlags -> [Dependency]
envPackages EnvFlags
envFlags)
      then (Maybe OriginalComponentInfo, ProjectBaseContext)
-> IO (Maybe OriginalComponentInfo, ProjectBaseContext)
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
_ -> 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)]
_) = (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> Maybe (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a. a -> Maybe a -> a
fromMaybe (SFlags -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
forall a. HasCallStack => SFlags -> a
error SFlags
"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 (SFlags -> PackageIdentifier
forall a. HasCallStack => SFlags -> a
error (SFlags -> PackageIdentifier) -> SFlags -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ SFlags
"cannot find " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ UnitId -> SFlags
forall a. Pretty a => a -> SFlags
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
envFlags) PackageIdentifier
pkgId ProjectBaseContext
baseCtx

          (Maybe OriginalComponentInfo, ProjectBaseContext)
-> IO (Maybe OriginalComponentInfo, ProjectBaseContext)
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') <- Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> ElaboratedSharedConfig
    -> IO (ProjectBuildContext, Compiler, ReplOptions))
-> IO (ProjectBuildContext, Compiler, ReplOptions)
forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan Verbosity
verbosity ProjectBaseContext
baseCtx' ((ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> IO (ProjectBuildContext, Compiler, ReplOptions))
 -> IO (ProjectBuildContext, Compiler, ReplOptions))
-> (ElaboratedInstallPlan
    -> ElaboratedSharedConfig
    -> IO (ProjectBuildContext, Compiler, ReplOptions))
-> IO (ProjectBuildContext, Compiler, ReplOptions)
forall a b. (a -> b) -> a -> b
$
      \ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
elaboratedShared' -> do
        let ProjectBaseContext{[PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))]
CabalDirLayout
DistDirLayout
BuildTimeSettings
ProjectConfig
CurrentCommand
currentCommand :: ProjectBaseContext -> CurrentCommand
localPackages :: ProjectBaseContext
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags)))]
projectConfig :: ProjectBaseContext -> ProjectConfig
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
currentCommand :: CurrentCommand
buildSettings :: BuildTimeSettings
localPackages :: [PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))]
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 = Bool -> Flag Bool -> Bool
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 -> SFlags -> IO ()
debugNoWrap Verbosity
verbosity (ElaboratedInstallPlan -> SFlags
forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> SFlags
InstallPlan.showInstallPlan ElaboratedInstallPlan
elaboratedPlan'')

        let
          buildCtx :: ProjectBuildContext
buildCtx = ProjectBuildContext :: ElaboratedInstallPlan
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
-> TargetsMap
-> ProjectBuildContext
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  -> []

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

    ReplOptions
replOpts'' <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> ReplOptions -> IO ReplOptions
forall (m :: * -> *) a. Monad m => a -> m a
return ReplOptions
replOpts'
      TargetContext
_              -> Compiler -> SFlags -> ReplOptions -> IO ReplOptions
usingGhciScript Compiler
compiler SFlags
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
    verbosity :: Verbosity
verbosity = Verbosity -> Flag 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 <- ([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 (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
              forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ReplProblem) [k]
selectPackageTargets
              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) (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
          [TargetsMap -> TargetProblem ReplProblem
multipleTargetsProblem TargetsMap
targets]

      TargetsMap -> IO TargetsMap
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 -> SFlags -> SFlags
[OriginalComponentInfo] -> SFlags -> SFlags
OriginalComponentInfo -> SFlags
(Int -> OriginalComponentInfo -> SFlags -> SFlags)
-> (OriginalComponentInfo -> SFlags)
-> ([OriginalComponentInfo] -> SFlags -> SFlags)
-> Show OriginalComponentInfo
forall a.
(Int -> a -> SFlags -> SFlags)
-> (a -> SFlags) -> ([a] -> SFlags -> SFlags) -> Show a
showList :: [OriginalComponentInfo] -> SFlags -> SFlags
$cshowList :: [OriginalComponentInfo] -> SFlags -> SFlags
show :: OriginalComponentInfo -> SFlags
$cshow :: OriginalComponentInfo -> SFlags
showsPrec :: Int -> OriginalComponentInfo -> SFlags -> SFlags
$cshowsPrec :: Int -> OriginalComponentInfo -> SFlags -> SFlags
Show)

addDepsToProjectTarget :: [Dependency]
                       -> PackageId
                       -> ProjectBaseContext
                       -> ProjectBaseContext
addDepsToProjectTarget :: [Dependency]
-> PackageIdentifier -> ProjectBaseContext -> ProjectBaseContext
addDepsToProjectTarget [Dependency]
deps PackageIdentifier
pkgId ProjectBaseContext
ctx =
    (\[PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))]
p -> ProjectBaseContext
ctx { localPackages :: [PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))]
localPackages = [PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))]
p }) ([PackageSpecifier
    (SourcePackage (PackageLocation (Maybe SFlags)))]
 -> ProjectBaseContext)
-> (ProjectBaseContext
    -> [PackageSpecifier
          (SourcePackage (PackageLocation (Maybe SFlags)))])
-> ProjectBaseContext
-> ProjectBaseContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))
 -> PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags))))
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags)))]
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags)))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))
-> PackageSpecifier
     (SourcePackage (PackageLocation (Maybe SFlags)))
addDeps ([PackageSpecifier
    (SourcePackage (PackageLocation (Maybe SFlags)))]
 -> [PackageSpecifier
       (SourcePackage (PackageLocation (Maybe SFlags)))])
-> (ProjectBaseContext
    -> [PackageSpecifier
          (SourcePackage (PackageLocation (Maybe SFlags)))])
-> ProjectBaseContext
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags)))]
localPackages (ProjectBaseContext -> ProjectBaseContext)
-> ProjectBaseContext -> ProjectBaseContext
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
ctx
  where
    addDeps :: PackageSpecifier UnresolvedSourcePackage
            -> PackageSpecifier UnresolvedSourcePackage
    addDeps :: PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))
-> PackageSpecifier
     (SourcePackage (PackageLocation (Maybe SFlags)))
addDeps (SpecificSourcePackage SourcePackage (PackageLocation (Maybe SFlags))
pkg)
      | SourcePackage (PackageLocation (Maybe SFlags)) -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId SourcePackage (PackageLocation (Maybe SFlags))
pkg PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageIdentifier
pkgId = SourcePackage (PackageLocation (Maybe SFlags))
-> PackageSpecifier
     (SourcePackage (PackageLocation (Maybe SFlags)))
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage SourcePackage (PackageLocation (Maybe SFlags))
pkg
      | SourcePackage{PackageDescriptionOverride
GenericPackageDescription
PackageIdentifier
PackageLocation (Maybe SFlags)
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 :: PackageLocation (Maybe SFlags)
srcpkgDescription :: GenericPackageDescription
srcpkgPackageId :: PackageIdentifier
..} <- SourcePackage (PackageLocation (Maybe SFlags))
pkg =
        SourcePackage (PackageLocation (Maybe SFlags))
-> PackageSpecifier
     (SourcePackage (PackageLocation (Maybe SFlags)))
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage (SourcePackage (PackageLocation (Maybe SFlags))
 -> PackageSpecifier
      (SourcePackage (PackageLocation (Maybe SFlags))))
-> SourcePackage (PackageLocation (Maybe SFlags))
-> PackageSpecifier
     (SourcePackage (PackageLocation (Maybe SFlags)))
forall a b. (a -> b) -> a -> b
$ SourcePackage (PackageLocation (Maybe SFlags))
pkg { srcpkgDescription :: GenericPackageDescription
srcpkgDescription =
          GenericPackageDescription
srcpkgDescription GenericPackageDescription
-> (GenericPackageDescription -> GenericPackageDescription)
-> GenericPackageDescription
forall a b. a -> (a -> b) -> b
& (\[Dependency] -> Identity [Dependency]
f -> (forall a.
 CondTree ConfVar [Dependency] a
 -> Identity (CondTree ConfVar [Dependency] a))
-> GenericPackageDescription -> Identity GenericPackageDescription
forall (f :: * -> *).
Applicative f =>
(forall a.
 CondTree ConfVar [Dependency] a
 -> f (CondTree ConfVar [Dependency] a))
-> GenericPackageDescription -> f GenericPackageDescription
L.allCondTrees ((forall a.
  CondTree ConfVar [Dependency] a
  -> Identity (CondTree ConfVar [Dependency] a))
 -> GenericPackageDescription -> Identity GenericPackageDescription)
-> (forall a.
    CondTree ConfVar [Dependency] a
    -> Identity (CondTree ConfVar [Dependency] a))
-> GenericPackageDescription
-> Identity GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ LensLike
  Identity
  (CondTree ConfVar [Dependency] a)
  (CondTree ConfVar [Dependency] a)
  [Dependency]
  [Dependency]
forall v c a d. Traversal (CondTree v c a) (CondTree v d a) c d
traverseCondTreeC [Dependency] -> Identity [Dependency]
f)
                            (([Dependency] -> Identity [Dependency])
 -> GenericPackageDescription -> Identity GenericPackageDescription)
-> ([Dependency] -> [Dependency])
-> GenericPackageDescription
-> GenericPackageDescription
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Dependency]
deps [Dependency] -> [Dependency] -> [Dependency]
forall a. [a] -> [a] -> [a]
++)
        }
    addDeps PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))
spec = PackageSpecifier (SourcePackage (PackageLocation (Maybe SFlags)))
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 =
      (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> [UnitId])
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [UnitId]
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 :: LFlags
flags  = (UnitId -> SFlags) -> [UnitId] -> LFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SFlags
"-package-id " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++) (SFlags -> SFlags) -> (UnitId -> SFlags) -> UnitId -> SFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> SFlags
forall a. Pretty a => a -> SFlags
prettyShow) ([UnitId] -> LFlags)
-> ([UnitId] -> [UnitId]) -> [UnitId] -> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UnitId] -> [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
exeDeps)
      ([UnitId] -> LFlags) -> [UnitId] -> LFlags
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 -> SFlags -> ReplOptions -> IO ReplOptions
usingGhciScript Compiler
compiler SFlags
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 :: SFlags
ghciScriptPath = SFlags
projectRoot SFlags -> SFlags -> SFlags
</> SFlags
"setcwd.ghci"
      SFlags
cwd <- IO SFlags
getCurrentDirectory
      SFlags -> SFlags -> IO ()
writeFile SFlags
ghciScriptPath (SFlags
":cd " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
cwd)
      ReplOptions -> IO ReplOptions
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 LFlags LFlags
Lens' ReplOptions LFlags
lReplOptionsFlags LensLike Identity ReplOptions ReplOptions LFlags LFlags
-> (LFlags -> LFlags) -> ReplOptions -> ReplOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((SFlags
"-ghci-script" SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
ghciScriptPath) SFlags -> LFlags -> LFlags
forall a. a -> [a] -> [a]
:)
  | Bool
otherwise = ReplOptions -> IO ReplOptions
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 :: 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
  = [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 (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsLibsBuildable)
  = TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
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
  = [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 (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsExesBuildable)
  = TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
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
  = [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 (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable)
  = TargetProblem ReplProblem -> Either (TargetProblem ReplProblem) [k]
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 ([AvailableTarget k] -> 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 :: 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 TargetSelector [AvailableTarget ()]

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

multipleTargetsProblem
  :: TargetsMap
  -> ReplTargetProblem
multipleTargetsProblem :: TargetsMap -> TargetProblem ReplProblem
multipleTargetsProblem = 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
. TargetsMap -> ReplProblem
TargetProblemMultipleTargets

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

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

renderReplProblem :: ReplProblem -> String
renderReplProblem :: ReplProblem -> SFlags
renderReplProblem (TargetProblemMatchesMultiple TargetSelector
targetSelector [AvailableTarget ()]
targets) =
    SFlags
"Cannot open a repl for multiple components at once. The target '"
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ TargetSelector -> SFlags
showTargetSelector TargetSelector
targetSelector SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"' refers to "
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ TargetSelector -> SFlags
renderTargetSelector TargetSelector
targetSelector SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
" which "
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ (if TargetSelector -> Bool
targetSelectorRefersToPkgs TargetSelector
targetSelector then SFlags
"includes " else SFlags
"are ")
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ LFlags -> SFlags
renderListSemiAnd
      [ SFlags
"the " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ Plural -> ComponentKind -> SFlags
renderComponentKind Plural
Plural ComponentKind
ckind SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
" " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++
        LFlags -> SFlags
renderListCommaAnd
          [ SFlags
-> (UnqualComponentName -> SFlags)
-> Maybe UnqualComponentName
-> SFlags
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageName -> SFlags
forall a. Pretty a => a -> SFlags
prettyShow PackageName
pkgname) UnqualComponentName -> SFlags
forall a. Pretty a => a -> SFlags
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
      ]
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
".\n\n" SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
explanationSingleComponentLimitation
  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 TargetsMap
selectorMap) =
    SFlags
"Cannot open a repl for multiple components at once. The targets "
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ LFlags -> SFlags
renderListCommaAnd
      [ SFlags
"'" SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ TargetSelector -> SFlags
showTargetSelector TargetSelector
ts SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
"'"
      | TargetSelector
ts <- TargetsMap -> [TargetSelector]
uniqueTargetSelectors TargetsMap
selectorMap ]
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
" refer to different components."
 SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
".\n\n" SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++ SFlags
explanationSingleComponentLimitation

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

-- Lenses
lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
lElaboratedShared :: LensLike
  f
  ProjectBuildContext
  ProjectBuildContext
  ElaboratedSharedConfig
  ElaboratedSharedConfig
lElaboratedShared ElaboratedSharedConfig -> f ElaboratedSharedConfig
f ProjectBuildContext
s = (ElaboratedSharedConfig -> ProjectBuildContext)
-> f ElaboratedSharedConfig -> f ProjectBuildContext
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 :: LensLike
  f
  ElaboratedSharedConfig
  ElaboratedSharedConfig
  ReplOptions
  ReplOptions
lPkgConfigReplOptions ReplOptions -> f ReplOptions
f ElaboratedSharedConfig
s = (ReplOptions -> ElaboratedSharedConfig)
-> f ReplOptions -> f ElaboratedSharedConfig
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 :: LensLike f ReplOptions ReplOptions LFlags LFlags
lReplOptionsFlags LFlags -> f LFlags
f ReplOptions
s = (LFlags -> ReplOptions) -> f LFlags -> f ReplOptions
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 #-}