cabal-install/src/Distribution/Client/CmdRepl.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4 {-# LANGUAGE TypeApplications #-}
   5
   6 -- | cabal-install CLI command: repl
   7 module Distribution.Client.CmdRepl
   8   ( -- * The @repl@ CLI and action
   9     replCommand
  10   , replAction
  11   , ReplFlags (..)
  12
  13     -- * Internals exposed for testing
  14   , matchesMultipleProblem
  15   , selectPackageTargets
  16   , selectComponentTarget
  17   , MultiReplDecision (..)
  18   ) where
  19
  20 import Distribution.Client.Compat.Prelude
  21 import Prelude ()
  22
  23 import Distribution.Compat.Lens
  24 import qualified Distribution.Types.Lens as L
  25
  26 import Distribution.Client.CmdErrorMessages
  27   ( Plural (..)
  28   , componentKind
  29   , renderComponentKind
  30   , renderListCommaAnd
  31   , renderListSemiAnd
  32   , renderTargetProblem
  33   , renderTargetSelector
  34   , showTargetSelector
  35   , sortGroupOn
  36   , targetSelectorRefersToPkgs
  37   )
  38 import Distribution.Client.DistDirLayout
  39   ( DistDirLayout (..)
  40   )
  41 import Distribution.Client.Errors
  42 import qualified Distribution.Client.InstallPlan as InstallPlan
  43 import Distribution.Client.NixStyleOptions
  44   ( NixStyleFlags (..)
  45   , defaultNixStyleFlags
  46   , nixStyleOptions
  47   )
  48 import Distribution.Client.ProjectBuilding
  49   ( improveInstallPlanWithUpToDatePackages
  50   , rebuildTargetsDryRun
  51   )
  52 import Distribution.Client.ProjectOrchestration
  53 import Distribution.Client.ProjectPlanning
  54   ( ElaboratedInstallPlan
  55   , ElaboratedSharedConfig (..)
  56   )
  57 import Distribution.Client.ProjectPlanning.Types
  58   ( elabOrderExeDependencies
  59   , showElaboratedInstallPlan
  60   )
  61 import Distribution.Client.ScriptUtils
  62   ( AcceptNoTargets (..)
  63   , TargetContext (..)
  64   , fakeProjectSourcePackage
  65   , lSrcpkgDescription
  66   , updateContextAndWriteProjectFile
  67   , updateContextAndWriteProjectFile'
  68   , withContextAndSelectors
  69   )
  70 import Distribution.Client.Setup
  71   ( ConfigFlags (..)
  72   , GlobalFlags
  73   )
  74 import qualified Distribution.Client.Setup as Client
  75 import Distribution.Client.TargetProblem
  76   ( TargetProblem (..)
  77   )
  78 import Distribution.Client.Targets
  79   ( UserConstraint (..)
  80   , UserConstraintScope (..)
  81   )
  82 import Distribution.Client.Types
  83   ( PackageSpecifier (..)
  84   , UnresolvedSourcePackage
  85   )
  86 import Distribution.Compiler
  87   ( CompilerFlavor (GHC)
  88   )
  89 import Distribution.Package
  90   ( Package (..)
  91   , UnitId
  92   , installedUnitId
  93   , mkPackageName
  94   , packageName
  95   )
  96 import Distribution.Simple.Command
  97   ( CommandUI (..)
  98   , usageAlternatives
  99   )
 100 import Distribution.Simple.Compiler
 101   ( Compiler
 102   , compilerCompatVersion
 103   )
 104 import Distribution.Simple.Setup
 105   ( ReplOptions (..)
 106   )
 107 import Distribution.Simple.Utils
 108   ( TempFileOptions (..)
 109   , debugNoWrap
 110   , dieWithException
 111   , withTempDirectoryEx
 112   , wrapText
 113   )
 114 import Distribution.Solver.Types.ConstraintSource
 115   ( ConstraintSource (ConstraintSourceMultiRepl)
 116   )
 117 import Distribution.Solver.Types.PackageConstraint
 118   ( PackageProperty (PackagePropertyVersion)
 119   )
 120 import Distribution.Solver.Types.SourcePackage
 121   ( SourcePackage (..)
 122   )
 123 import Distribution.Types.BuildInfo
 124   ( BuildInfo (..)
 125   , emptyBuildInfo
 126   )
 127 import Distribution.Types.ComponentName
 128   ( componentNameString
 129   )
 130 import Distribution.Types.CondTree
 131   ( CondTree (..)
 132   )
 133 import Distribution.Types.Dependency
 134   ( Dependency (..)
 135   , mainLibSet
 136   )
 137 import Distribution.Types.Library
 138   ( Library (..)
 139   , emptyLibrary
 140   )
 141 import Distribution.Types.Version
 142   ( Version
 143   , mkVersion
 144   )
 145 import Distribution.Types.VersionRange
 146   ( anyVersion
 147   , orLaterVersion
 148   )
 149 import Distribution.Utils.Generic
 150   ( safeHead
 151   )
 152 import Distribution.Verbosity
 153   ( lessVerbose
 154   , normal
 155   )
 156 import Language.Haskell.Extension
 157   ( Language (..)
 158   )
 159
 160 import Control.Monad (mapM)
 161 import qualified Data.ByteString.Lazy as BS
 162 import Data.List
 163   ( (\\)
 164   )
 165 import qualified Data.Map as Map
 166 import qualified Data.Set as Set
 167 import Distribution.Client.ProjectConfig
 168   ( ProjectConfig (projectConfigShared)
 169   , ProjectConfigShared (projectConfigConstraints, projectConfigMultiRepl)
 170   )
 171 import Distribution.Client.ReplFlags
 172   ( EnvFlags (envIncludeTransitive, envPackages)
 173   , ReplFlags (..)
 174   , defaultReplFlags
 175   , topReplOptions
 176   )
 177 import Distribution.Compat.Binary (decode)
 178 import Distribution.Simple.Flag (Flag (Flag), fromFlagOrDefault)
 179 import Distribution.Simple.Program.Builtin (ghcProgram)
 180 import Distribution.Simple.Program.Db (requireProgram)
 181 import Distribution.Simple.Program.Run
 182   ( programInvocation
 183   , runProgramInvocation
 184   )
 185 import Distribution.Simple.Program.Types
 186   ( ConfiguredProgram (programOverrideEnv)
 187   )
 188 import System.Directory
 189   ( doesFileExist
 190   , getCurrentDirectory
 191   , listDirectory
 192   , makeAbsolute
 193   )
 194 import System.FilePath
 195   ( searchPathSeparator
 196   , splitSearchPath
 197   , (</>)
 198   )
 199
 200 replCommand :: CommandUI (NixStyleFlags ReplFlags)
 201 replCommand =
 202   Client.installCommand
 203     { commandName = "v2-repl"
 204     , commandSynopsis = "Open an interactive session for the given component."
 205     , commandUsage = usageAlternatives "v2-repl" ["[TARGET] [FLAGS]"]
 206     , commandDescription = Just $ \_ ->
 207         wrapText $
 208           "Open an interactive session for a component within the project. The "
 209             ++ "available targets are the same as for the 'v2-build' command: "
 210             ++ "individual components within packages in the project, including "
 211             ++ "libraries, executables, test-suites or benchmarks. Packages can "
 212             ++ "also be specified in which case the library component in the "
 213             ++ "package will be used, or the (first listed) executable in the "
 214             ++ "package if there is no library.\n\n"
 215             ++ "Dependencies are built or rebuilt as necessary. Additional "
 216             ++ "configuration flags can be specified on the command line and these "
 217             ++ "extend the project configuration from the 'cabal.project', "
 218             ++ "'cabal.project.local' and other files."
 219     , commandNotes = Just $ \pname ->
 220         "Examples, open an interactive session:\n"
 221           ++ "  "
 222           ++ pname
 223           ++ " v2-repl\n"
 224           ++ "    for the default component in the package in the current directory\n"
 225           ++ "  "
 226           ++ pname
 227           ++ " v2-repl pkgname\n"
 228           ++ "    for the default component in the package named 'pkgname'\n"
 229           ++ "  "
 230           ++ pname
 231           ++ " v2-repl ./pkgfoo\n"
 232           ++ "    for the default component in the package in the ./pkgfoo directory\n"
 233           ++ "  "
 234           ++ pname
 235           ++ " v2-repl cname\n"
 236           ++ "    for the component named 'cname'\n"
 237           ++ "  "
 238           ++ pname
 239           ++ " v2-repl pkgname:cname\n"
 240           ++ "    for the component 'cname' in the package 'pkgname'\n\n"
 241           ++ "  "
 242           ++ pname
 243           ++ " v2-repl --build-depends lens\n"
 244           ++ "    add the latest version of the library 'lens' to the default component "
 245           ++ "(or no componentif there is no project present)\n"
 246           ++ "  "
 247           ++ pname
 248           ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
 249           ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "
 250           ++ "to the default component (or no component if there is no project present)\n"
 251     , commandDefaultFlags = defaultNixStyleFlags defaultReplFlags
 252     , commandOptions = nixStyleOptions topReplOptions
 253     }
 254
 255 data MultiReplDecision = MultiReplDecision
 256   { compilerVersion :: Maybe Version
 257   , enabledByFlag :: Bool
 258   }
 259   deriving (Eq, Show)
 260
 261 useMultiRepl :: MultiReplDecision -> Bool
 262 useMultiRepl MultiReplDecision{compilerVersion, enabledByFlag} =
 263   compilerVersion >= Just minMultipleHomeUnitsVersion && enabledByFlag
 264
 265 multiReplDecision :: ProjectConfigShared -> Compiler -> ReplFlags -> MultiReplDecision
 266 multiReplDecision ctx compiler flags =
 267   MultiReplDecision
 268     -- Check if the compiler is new enough, need at least 9.4 to start a multi session
 269     (compilerCompatVersion GHC compiler)
 270     -- Then check the user actually asked for it, either via the project file, the global config or
 271     -- a repl specific option.
 272     (fromFlagOrDefault False (projectConfigMultiRepl ctx <> replUseMulti flags))
 273
 274 -- | The @repl@ command is very much like @build@. It brings the install plan
 275 -- up to date, selects that part of the plan needed by the given or implicit
 276 -- repl target and then executes the plan.
 277 --
 278 -- Compared to @build@ the difference is that multiple targets are handled
 279 -- specially and the target type is repl rather than build. The
 280 -- general plan execution infrastructure handles both build and repl targets.
 281 --
 282 -- For more details on how this works, see the module
 283 -- "Distribution.Client.ProjectOrchestration"
 284 replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO ()
 285 replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags =
 286   withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do
 287     when (buildSettingOnlyDeps (buildSettings ctx)) $
 288       dieWithException verbosity ReplCommandDoesn'tSupport
 289     let projectRoot = distProjectRootDirectory $ distDirLayout ctx
 290         distDir = distDirectory $ distDirLayout ctx
 291
 292     baseCtx <- case targetCtx of
 293       ProjectContext -> return ctx
 294       GlobalContext -> do
 295         unless (null targetStrings) $
 296           dieWithException verbosity $
 297             ReplTakesNoArguments targetStrings
 298         let
 299           sourcePackage =
 300             fakeProjectSourcePackage projectRoot
 301               & lSrcpkgDescription . L.condLibrary
 302                 .~ Just (CondNode library [baseDep] [])
 303           library = emptyLibrary{libBuildInfo = lBuildInfo}
 304           lBuildInfo =
 305             emptyBuildInfo
 306               { targetBuildDepends = [baseDep]
 307               , defaultLanguage = Just Haskell2010
 308               }
 309           baseDep = Dependency "base" anyVersion mainLibSet
 310
 311         updateContextAndWriteProjectFile' ctx sourcePackage
 312       ScriptContext scriptPath scriptExecutable -> do
 313         unless (length targetStrings == 1) $
 314           dieWithException verbosity $
 315             ReplTakesSingleArgument targetStrings
 316         existsScriptPath <- doesFileExist scriptPath
 317         unless existsScriptPath $
 318           dieWithException verbosity $
 319             ReplTakesSingleArgument targetStrings
 320
 321         updateContextAndWriteProjectFile ctx scriptPath scriptExecutable
 322
 323     -- If multi-repl is used, we need a Cabal recent enough to handle it.
 324     -- We need to do this before solving, but the compiler version is only known
 325     -- after solving (phaseConfigureCompiler), so instead of using
 326     -- multiReplDecision we just check the flag.
 327     let baseCtx' =
 328           if fromFlagOrDefault False $
 329             projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx)
 330               <> replUseMulti
 331             then
 332               baseCtx
 333                 & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints
 334                   %~ (multiReplCabalConstraint :)
 335             else baseCtx
 336
 337     (originalComponent, baseCtx'') <-
 338       if null (envPackages replEnvFlags)
 339         then return (Nothing, baseCtx')
 340         else -- Unfortunately, the best way to do this is to let the normal solver
 341         -- help us resolve the targets, but that isn't ideal for performance,
 342         -- especially in the no-project case.
 343         withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do
 344           -- targets should be non-empty map, but there's no NonEmptyMap yet.
 345           targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors
 346
 347           let
 348             (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
 349             originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId
 350             oci = OriginalComponentInfo unitId originalDeps
 351             pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId
 352             baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx'
 353
 354           return (Just oci, baseCtx'')
 355
 356     -- Now, we run the solver again with the added packages. While the graph
 357     -- won't actually reflect the addition of transitive dependencies,
 358     -- they're going to be available already and will be offered to the REPL
 359     -- and that's good enough.
 360     --
 361     -- In addition, to avoid a *third* trip through the solver, we are
 362     -- replicating the second half of 'runProjectPreBuildPhase' by hand
 363     -- here.
 364     (buildCtx, compiler, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $
 365       \elaboratedPlan elaboratedShared' -> do
 366         let ProjectBaseContext{..} = baseCtx''
 367
 368         -- Recalculate with updated project.
 369         targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors
 370
 371         let
 372           elaboratedPlan' =
 373             pruneInstallPlanToTargets
 374               TargetActionRepl
 375               targets
 376               elaboratedPlan
 377           includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
 378
 379         pkgsBuildStatus <-
 380           rebuildTargetsDryRun
 381             distDirLayout
 382             elaboratedShared'
 383             elaboratedPlan'
 384
 385         let elaboratedPlan'' =
 386               improveInstallPlanWithUpToDatePackages
 387                 pkgsBuildStatus
 388                 elaboratedPlan'
 389         debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'')
 390
 391         let
 392           buildCtx =
 393             ProjectBuildContext
 394               { elaboratedPlanOriginal = elaboratedPlan
 395               , elaboratedPlanToExecute = elaboratedPlan''
 396               , elaboratedShared = elaboratedShared'
 397               , pkgsBuildStatus
 398               , targetsMap = targets
 399               }
 400
 401           ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared'
 402
 403           repl_flags = case originalComponent of
 404             Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
 405             Nothing -> []
 406
 407         return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets)
 408
 409     -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for
 410     -- a high-level overview about how everything fits together.
 411     if Set.size (distinctTargetComponents targets) > 1
 412       then withTempDirectoryEx verbosity (TempFileOptions keepTempFiles) distDir "multi-out" $ \dir' -> do
 413         -- multi target repl
 414         dir <- makeAbsolute dir'
 415         -- Modify the replOptions so that the ./Setup repl command will write options
 416         -- into the multi-out directory.
 417         replOpts'' <- case targetCtx of
 418           ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir}
 419           _ -> usingGhciScript compiler projectRoot replOpts'
 420
 421         let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
 422         printPlan verbosity baseCtx'' buildCtx'
 423
 424         -- The project build phase will call `./Setup repl` but write the options
 425         -- out into a file without starting a repl.
 426         buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx'
 427         runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes
 428
 429         -- calculate PATH, we construct a PATH which is the union of all paths from
 430         -- the units which have been loaded. This is not quite right but usually works fine.
 431         path_files <- listDirectory (dir </> "paths")
 432
 433         -- Note: decode is partial. Should we use Structured here?
 434         -- This might blow up with @build-type: Custom@ stuff.
 435         ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir </> "paths" </> f)) path_files
 436
 437         let all_paths = concatMap programOverrideEnv ghcProgs
 438         let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths)))
 439         -- HACK: Just combine together all env overrides, placing the most common things last
 440
 441         -- ghc program with overriden PATH
 442         (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx'))
 443         let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]}
 444
 445         -- Find what the unit files are, and start a repl based on all the response
 446         -- files which have been created in the directory.
 447         -- unit files for components
 448         unit_files <- listDirectory dir
 449
 450         -- Order the unit files so that the find target becomes the active unit
 451         let active_unit_fp :: Maybe FilePath
 452             active_unit_fp = do
 453               -- Get the first target selectors from the cli
 454               activeTarget <- safeHead targetSelectors
 455               -- Lookup the targets :: Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]
 456               unitId <-
 457                 Map.toList targets
 458                   -- Keep the UnitId matching the desired target selector
 459                   & find (\(_, xs) -> any (\(_, selectors) -> activeTarget `elem` selectors) xs)
 460                   & fmap fst
 461               -- Convert to filename (adapted from 'storePackageDirectory')
 462               pure (prettyShow unitId)
 463             unit_files_ordered :: [FilePath]
 464             unit_files_ordered =
 465               let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files
 466                in -- GHC considers the last unit passed to be the active one
 467                   other_units ++ active_unit_files
 468
 469         -- run ghc --interactive with
 470         runProgramInvocation verbosity $
 471           programInvocation ghcProg' $
 472             concat $
 473               [ "--interactive"
 474               , "-package-env"
 475               , "-" -- to ignore ghc.environment.* files
 476               , "-j"
 477               , show (buildSettingNumJobs (buildSettings ctx))
 478               ]
 479                 : [ ["-unit", "@" ++ dir </> unit]
 480                   | unit <- unit_files_ordered
 481                   , unit /= "paths"
 482                   ]
 483
 484         pure ()
 485       else do
 486         -- single target repl
 487         replOpts'' <- case targetCtx of
 488           ProjectContext -> return replOpts'
 489           _ -> usingGhciScript compiler projectRoot replOpts'
 490
 491         let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
 492         printPlan verbosity baseCtx'' buildCtx'
 493
 494         buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx'
 495         runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes
 496   where
 497     combine_search_paths paths =
 498       foldl' go Map.empty paths
 499       where
 500         go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s)
 501         go m _ = m
 502
 503     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 504     keepTempFiles = fromFlagOrDefault False replKeepTempFiles
 505
 506     validatedTargets ctx compiler elaboratedPlan targetSelectors = do
 507       let multi_repl_enabled = multiReplDecision ctx compiler r
 508       -- Interpret the targets on the command line as repl targets
 509       -- (as opposed to say build or haddock targets).
 510       targets <-
 511         either (reportTargetProblems verbosity) return $
 512           resolveTargets
 513             (selectPackageTargets multi_repl_enabled)
 514             selectComponentTarget
 515             elaboratedPlan
 516             Nothing
 517             targetSelectors
 518
 519       -- Reject multiple targets, or at least targets in different
 520       -- components. It is ok to have two module/file targets in the
 521       -- same component, but not two that live in different components.
 522       when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $
 523         reportTargetProblems
 524           verbosity
 525           [multipleTargetsProblem multi_repl_enabled targets]
 526
 527       return targets
 528
 529     -- This is the constraint setup.Cabal>=3.11. 3.11 is when Cabal options
 530     -- used for multi-repl were introduced.
 531     -- Idelly we'd apply this constraint only on the closure of repl targets,
 532     -- but that would require another solver run for marginal advantages that
 533     -- will further shrink as 3.11 is adopted.
 534     multiReplCabalConstraint =
 535       ( UserConstraint
 536           (UserAnySetupQualifier (mkPackageName "Cabal"))
 537           (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11])
 538       , ConstraintSourceMultiRepl
 539       )
 540
 541 -- | First version of GHC which supports multiple home packages
 542 minMultipleHomeUnitsVersion :: Version
 543 minMultipleHomeUnitsVersion = mkVersion [9, 4]
 544
 545 data OriginalComponentInfo = OriginalComponentInfo
 546   { ociUnitId :: UnitId
 547   , ociOriginalDeps :: [UnitId]
 548   }
 549   deriving (Show)
 550
 551 addDepsToProjectTarget
 552   :: [Dependency]
 553   -> PackageId
 554   -> ProjectBaseContext
 555   -> ProjectBaseContext
 556 addDepsToProjectTarget deps pkgId ctx =
 557   (\p -> ctx{localPackages = p}) . fmap addDeps . localPackages $ ctx
 558   where
 559     addDeps
 560       :: PackageSpecifier UnresolvedSourcePackage
 561       -> PackageSpecifier UnresolvedSourcePackage
 562     addDeps (SpecificSourcePackage pkg)
 563       | packageId pkg /= pkgId = SpecificSourcePackage pkg
 564       | SourcePackage{..} <- pkg =
 565           SpecificSourcePackage $
 566             pkg
 567               { srcpkgDescription =
 568                   -- New dependencies are added to the original ones found in the
 569                   -- `targetBuildDepends` field.
 570                   -- `traverseBuildInfos` is used in order to update _all_ the
 571                   -- occurrences of the field `targetBuildDepends`. It ensures that
 572                   -- fields depending on the latter are also consistently updated.
 573                   srcpkgDescription
 574                     & (L.traverseBuildInfos . L.targetBuildDepends)
 575                       %~ (deps ++)
 576               }
 577     addDeps spec = spec
 578
 579 generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String]
 580 generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags
 581   where
 582     exeDeps :: [UnitId]
 583     exeDeps =
 584       foldMap
 585         (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)
 586         (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])
 587
 588     deps, deps', trans, trans' :: [UnitId]
 589     flags :: [String]
 590     deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
 591     deps' = deps \\ ociOriginalDeps
 592     trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
 593     trans' = trans \\ ociOriginalDeps
 594     flags =
 595       fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $
 596         if includeTransitive then trans' else deps'
 597
 598 -- | Add repl options to ensure the repl actually starts in the current working directory.
 599 --
 600 -- In a global or script context, when we are using a fake package, @cabal repl@
 601 -- starts in the fake package directory instead of the directory it was called from,
 602 -- so we need to tell ghci to change back to the correct directory.
 603 --
 604 -- The @-ghci-script@ flag is path to the ghci script responsible for changing to the
 605 -- correct directory. Only works on GHC >= 7.6, though. 🙁
 606 usingGhciScript :: Compiler -> FilePath -> ReplOptions -> IO ReplOptions
 607 usingGhciScript compiler projectRoot replOpts
 608   | compilerCompatVersion GHC compiler >= Just minGhciScriptVersion = do
 609       let ghciScriptPath = projectRoot </> "setcwd.ghci"
 610       cwd <- getCurrentDirectory
 611       writeFile ghciScriptPath (":cd " ++ cwd)
 612       return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :)
 613   | otherwise = return replOpts
 614
 615 -- | First version of GHC where GHCi supported the flag we need.
 616 -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html
 617 minGhciScriptVersion :: Version
 618 minGhciScriptVersion = mkVersion [7, 6]
 619
 620 -- | This defines what a 'TargetSelector' means for the @repl@ command.
 621 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 622 -- or otherwise classifies the problem.
 623 --
 624 -- For repl we select:
 625 --
 626 -- * the library if there is only one and it's buildable; or
 627 --
 628 -- * the exe if there is only one and it's buildable; or
 629 --
 630 -- * any other buildable component.
 631 --
 632 -- Fail if there are no buildable lib\/exe components, or if there are
 633 -- multiple libs or exes.
 634 selectPackageTargets
 635   :: MultiReplDecision
 636   -> TargetSelector
 637   -> [AvailableTarget k]
 638   -> Either ReplTargetProblem [k]
 639 selectPackageTargets multiple_targets_allowed =
 640   -- If explicitly enabled, then select the targets like we would for multi-repl but
 641   -- might still fail later because of compiler version.
 642   if enabledByFlag multiple_targets_allowed
 643     then selectPackageTargetsMulti
 644     else selectPackageTargetsSingle multiple_targets_allowed
 645
 646 selectPackageTargetsMulti
 647   :: TargetSelector
 648   -> [AvailableTarget k]
 649   -> Either ReplTargetProblem [k]
 650 selectPackageTargetsMulti targetSelector targets
 651   | not (null targetsBuildable) =
 652       Right targetsBuildable
 653   -- If there are no targets at all then we report that
 654   | otherwise =
 655       Left (TargetProblemNoTargets targetSelector)
 656   where
 657     ( targetsBuildable
 658       , _
 659       ) =
 660         selectBuildableTargetsWith'
 661           (isRequested targetSelector)
 662           targets
 663
 664     -- When there's a target filter like "pkg:tests" then we do select tests,
 665     -- but if it's just a target like "pkg" then we don't build tests unless
 666     -- they are requested by default (i.e. by using --enable-tests)
 667     isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
 668     isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
 669     isRequested _ _ = True
 670
 671 -- | Target selection behaviour which only select a single target.
 672 -- This is used when the compiler version doesn't support multi-repl or the user
 673 -- didn't request it.
 674 selectPackageTargetsSingle
 675   :: MultiReplDecision
 676   -> TargetSelector
 677   -> [AvailableTarget k]
 678   -> Either ReplTargetProblem [k]
 679 selectPackageTargetsSingle decision targetSelector targets
 680   -- If there is exactly one buildable library then we select that
 681   | [target] <- targetsLibsBuildable =
 682       Right [target]
 683   -- but fail if there are multiple buildable libraries.
 684   | not (null targetsLibsBuildable) =
 685       Left (matchesMultipleProblem decision targetSelector targetsLibsBuildable')
 686   -- If there is exactly one buildable executable then we select that
 687   | [target] <- targetsExesBuildable =
 688       Right [target]
 689   -- but fail if there are multiple buildable executables.
 690   | not (null targetsExesBuildable) =
 691       Left (matchesMultipleProblem decision targetSelector targetsExesBuildable')
 692   -- If there is exactly one other target then we select that
 693   | [target] <- targetsBuildable =
 694       Right [target]
 695   -- but fail if there are multiple such targets
 696   | not (null targetsBuildable) =
 697       Left (matchesMultipleProblem decision targetSelector targetsBuildable')
 698   -- If there are targets but none are buildable then we report those
 699   | not (null targets) =
 700       Left (TargetProblemNoneEnabled targetSelector targets')
 701   -- If there are no targets at all then we report that
 702   | otherwise =
 703       Left (TargetProblemNoTargets targetSelector)
 704   where
 705     targets' = forgetTargetsDetail targets
 706     ( targetsLibsBuildable
 707       , targetsLibsBuildable'
 708       ) =
 709         selectBuildableTargets'
 710           . filterTargetsKind LibKind
 711           $ targets
 712     ( targetsExesBuildable
 713       , targetsExesBuildable'
 714       ) =
 715         selectBuildableTargets'
 716           . filterTargetsKind ExeKind
 717           $ targets
 718     ( targetsBuildable
 719       , targetsBuildable'
 720       ) =
 721         selectBuildableTargetsWith'
 722           (isRequested targetSelector)
 723           targets
 724
 725     -- When there's a target filter like "pkg:tests" then we do select tests,
 726     -- but if it's just a target like "pkg" then we don't build tests unless
 727     -- they are requested by default (i.e. by using --enable-tests)
 728     isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
 729     isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
 730     isRequested _ _ = True
 731
 732 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
 733 -- selected.
 734 --
 735 -- For the @repl@ command we just need the basic checks on being buildable etc.
 736 selectComponentTarget
 737   :: SubComponentTarget
 738   -> AvailableTarget k
 739   -> Either ReplTargetProblem k
 740 selectComponentTarget = selectComponentTargetBasic
 741
 742 data ReplProblem
 743   = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()]
 744   | -- | Multiple 'TargetSelector's match multiple targets
 745     TargetProblemMultipleTargets MultiReplDecision TargetsMap
 746   deriving (Eq, Show)
 747
 748 -- | The various error conditions that can occur when matching a
 749 -- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.
 750 type ReplTargetProblem = TargetProblem ReplProblem
 751
 752 matchesMultipleProblem
 753   :: MultiReplDecision
 754   -> TargetSelector
 755   -> [AvailableTarget ()]
 756   -> ReplTargetProblem
 757 matchesMultipleProblem decision targetSelector targetsExesBuildable =
 758   CustomTargetProblem $ TargetProblemMatchesMultiple decision targetSelector targetsExesBuildable
 759
 760 multipleTargetsProblem
 761   :: MultiReplDecision
 762   -> TargetsMap
 763   -> ReplTargetProblem
 764 multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision
 765
 766 reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
 767 reportTargetProblems verbosity =
 768   dieWithException verbosity . RenderReplTargetProblem . map renderReplTargetProblem
 769
 770 renderReplTargetProblem :: TargetProblem ReplProblem -> String
 771 renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem
 772
 773 renderReplProblem :: ReplProblem -> String
 774 renderReplProblem (TargetProblemMatchesMultiple decision targetSelector targets) =
 775   "Cannot open a repl for multiple components at once. The target '"
 776     ++ showTargetSelector targetSelector
 777     ++ "' refers to "
 778     ++ renderTargetSelector targetSelector
 779     ++ " which "
 780     ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ")
 781     ++ renderListSemiAnd
 782       [ "the "
 783         ++ renderComponentKind Plural ckind
 784         ++ " "
 785         ++ renderListCommaAnd
 786           [ maybe (prettyShow pkgname) prettyShow (componentNameString cname)
 787           | t <- ts
 788           , let cname = availableTargetComponentName t
 789                 pkgname = packageName (availableTargetPackageId t)
 790           ]
 791       | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets
 792       ]
 793     ++ ".\n\n"
 794     ++ explainMultiReplDecision decision
 795   where
 796     availableTargetComponentKind =
 797       componentKind
 798         . availableTargetComponentName
 799 renderReplProblem (TargetProblemMultipleTargets multi_decision selectorMap) =
 800   "Cannot open a repl for multiple components at once. The targets "
 801     ++ renderListCommaAnd
 802       [ "'" ++ showTargetSelector ts ++ "'"
 803       | ts <- uniqueTargetSelectors selectorMap
 804       ]
 805     ++ " refer to different components."
 806     ++ ".\n\n"
 807     ++ explainMultiReplDecision multi_decision
 808
 809 explainMultiReplDecision :: MultiReplDecision -> [Char]
 810 explainMultiReplDecision MultiReplDecision{compilerVersion, enabledByFlag} =
 811   case (compilerVersion >= Just minMultipleHomeUnitsVersion, enabledByFlag) of
 812     -- Compiler not new enough, and not requested anyway.
 813     (False, False) -> explanationSingleComponentLimitation compilerVersion
 814     -- Compiler too old, but was requested
 815     (False, True) -> "Multiple component session requested but compiler version is too old.\n" ++ explanationSingleComponentLimitation compilerVersion
 816     -- Compiler new enough, but not requested
 817     (True, False) -> explanationNeedToEnableFlag
 818     _ -> error "explainMultiReplDecision"
 819
 820 explanationNeedToEnableFlag :: String
 821 explanationNeedToEnableFlag =
 822   "Your compiler supports a multiple component repl but support is not enabled.\n"
 823     ++ "The experimental multi repl can be enabled by\n"
 824     ++ "  * Globally: Setting multi-repl: True in your .cabal/config\n"
 825     ++ "  * Project Wide: Setting multi-repl: True in your cabal.project file\n"
 826     ++ "  * Per Invocation: By passing --enable-multi-repl when starting the repl"
 827
 828 explanationSingleComponentLimitation :: Maybe Version -> String
 829 explanationSingleComponentLimitation version =
 830   "The reason for this limitation is that your version "
 831     ++ versionString
 832     ++ "of ghci does not "
 833     ++ "support loading multiple components as source. Load just one component "
 834     ++ "and when you make changes to a dependent component then quit and reload.\n"
 835     ++ prettyShow minMultipleHomeUnitsVersion
 836     ++ " is needed to support multiple component sessions."
 837   where
 838     versionString = case version of
 839       Nothing -> ""
 840       Just ver -> "(" ++ prettyShow ver ++ ") "
 841
 842 -- Lenses
 843 lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
 844 lElaboratedShared f s = fmap (\x -> s{elaboratedShared = x}) (f (elaboratedShared s))
 845 {-# INLINE lElaboratedShared #-}
 846
 847 lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions
 848 lPkgConfigReplOptions f s = fmap (\x -> s{pkgConfigReplOptions = x}) (f (pkgConfigReplOptions s))
 849 {-# INLINE lPkgConfigReplOptions #-}
 850
 851 lReplOptionsFlags :: Lens' ReplOptions [String]
 852 lReplOptionsFlags f s = fmap (\x -> s{replOptionsFlags = x}) (f (replOptionsFlags s))
 853 {-# INLINE lReplOptionsFlags #-}
 854
 855 lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
 856 lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s))
 857 {-# INLINE lProjectConfig #-}
 858
 859 lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared
 860 lProjectConfigShared f s = fmap (\x -> s{projectConfigShared = x}) (f (projectConfigShared s))
 861 {-# INLINE lProjectConfigShared #-}
 862
 863 lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]
 864 lProjectConfigConstraints f s = fmap (\x -> s{projectConfigConstraints = x}) (f (projectConfigConstraints s))
 865 {-# INLINE lProjectConfigConstraints #-}