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