Merge pull request #10593 from cabalism/typo/prexif-reseved
[cabal.git] / cabal-install / src / Distribution / Client / CmdRepl.hs
blobf762c3d72bff5d8ea9d210bdb37202e7bf28d709
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# LANGUAGE TypeApplications #-}
6 -- | cabal-install CLI command: repl
7 module Distribution.Client.CmdRepl
8 ( -- * The @repl@ CLI and action
9 replCommand
10 , replAction
11 , ReplFlags (..)
13 -- * Internals exposed for testing
14 , matchesMultipleProblem
15 , selectPackageTargets
16 , selectComponentTarget
17 , MultiReplDecision (..)
18 ) where
20 import Distribution.Client.Compat.Prelude
21 import Prelude ()
23 import Distribution.Compat.Lens
24 import qualified Distribution.Types.Lens as L
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
38 import Distribution.Client.DistDirLayout
39 ( DistDirLayout (..)
41 import Distribution.Client.Errors
42 import qualified Distribution.Client.InstallPlan as InstallPlan
43 import Distribution.Client.NixStyleOptions
44 ( NixStyleFlags (..)
45 , defaultNixStyleFlags
46 , nixStyleOptions
48 import Distribution.Client.ProjectBuilding
49 ( improveInstallPlanWithUpToDatePackages
50 , rebuildTargetsDryRun
52 import Distribution.Client.ProjectOrchestration
53 import Distribution.Client.ProjectPlanning
54 ( ElaboratedInstallPlan
55 , ElaboratedSharedConfig (..)
57 import Distribution.Client.ProjectPlanning.Types
58 ( elabOrderExeDependencies
59 , showElaboratedInstallPlan
61 import Distribution.Client.ScriptUtils
62 ( AcceptNoTargets (..)
63 , TargetContext (..)
64 , fakeProjectSourcePackage
65 , lSrcpkgDescription
66 , updateContextAndWriteProjectFile
67 , updateContextAndWriteProjectFile'
68 , withContextAndSelectors
70 import Distribution.Client.Setup
71 ( ConfigFlags (..)
72 , GlobalFlags
74 import qualified Distribution.Client.Setup as Client
75 import Distribution.Client.TargetProblem
76 ( TargetProblem (..)
78 import Distribution.Client.Targets
79 ( UserConstraint (..)
80 , UserConstraintScope (..)
82 import Distribution.Client.Types
83 ( PackageSpecifier (..)
84 , UnresolvedSourcePackage
86 import Distribution.Compiler
87 ( CompilerFlavor (GHC)
89 import Distribution.Package
90 ( Package (..)
91 , UnitId
92 , installedUnitId
93 , mkPackageName
94 , packageName
96 import Distribution.Simple.Command
97 ( CommandUI (..)
98 , usageAlternatives
100 import Distribution.Simple.Compiler
101 ( Compiler
102 , compilerCompatVersion
104 import Distribution.Simple.Setup
105 ( ReplOptions (..)
106 , commonSetupTempFileOptions
107 , setupVerbosity
109 import Distribution.Simple.Utils
110 ( debugNoWrap
111 , dieWithException
112 , withTempDirectoryEx
113 , wrapText
115 import Distribution.Solver.Types.ConstraintSource
116 ( ConstraintSource (ConstraintSourceMultiRepl)
118 import Distribution.Solver.Types.PackageConstraint
119 ( PackageProperty (PackagePropertyVersion)
121 import Distribution.Solver.Types.SourcePackage
122 ( SourcePackage (..)
124 import Distribution.Types.BuildInfo
125 ( BuildInfo (..)
126 , emptyBuildInfo
128 import Distribution.Types.ComponentName
129 ( componentNameString
131 import Distribution.Types.CondTree
132 ( CondTree (..)
134 import Distribution.Types.Dependency
135 ( Dependency (..)
136 , mainLibSet
138 import Distribution.Types.Library
139 ( Library (..)
140 , emptyLibrary
142 import Distribution.Types.ParStrat
143 import Distribution.Types.Version
144 ( Version
145 , mkVersion
147 import Distribution.Types.VersionRange
148 ( anyVersion
149 , orLaterVersion
151 import Distribution.Utils.Generic
152 ( safeHead
154 import Distribution.Verbosity
155 ( lessVerbose
156 , normal
158 import Language.Haskell.Extension
159 ( Language (..)
162 import Control.Monad (mapM)
163 import qualified Data.ByteString.Lazy as BS
164 import Data.List
165 ( (\\)
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)
173 import Distribution.Client.ReplFlags
174 ( EnvFlags (envIncludeTransitive, envPackages)
175 , ReplFlags (..)
176 , defaultReplFlags
177 , topReplOptions
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
187 import Distribution.Simple.Program.Types
188 ( ConfiguredProgram (programOverrideEnv)
190 import System.Directory
191 ( doesFileExist
192 , getCurrentDirectory
193 , listDirectory
194 , makeAbsolute
196 import System.FilePath
197 ( searchPathSeparator
198 , splitSearchPath
199 , (</>)
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
257 data MultiReplDecision = MultiReplDecision
258 { compilerVersion :: Maybe Version
259 , enabledByFlag :: Bool
261 deriving (Eq, Show)
263 useMultiRepl :: MultiReplDecision -> Bool
264 useMultiRepl MultiReplDecision{compilerVersion, enabledByFlag} =
265 compilerVersion >= Just minMultipleHomeUnitsVersion && enabledByFlag
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))
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.
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.
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
294 baseCtx <- case targetCtx of
295 ProjectContext -> return ctx
296 GlobalContext -> do
297 unless (null targetStrings) $
298 dieWithException verbosity $
299 ReplTakesNoArguments targetStrings
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
311 baseDep = Dependency "base" anyVersion mainLibSet
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
323 updateContextAndWriteProjectFile ctx scriptPath scriptExecutable
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
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
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'
356 return (Just oci, baseCtx'')
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.
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''
370 -- Recalculate with updated project.
371 targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors
374 elaboratedPlan' =
375 pruneInstallPlanToTargets
376 TargetActionRepl
377 targets
378 elaboratedPlan
379 includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
381 pkgsBuildStatus <-
382 rebuildTargetsDryRun
383 distDirLayout
384 elaboratedShared'
385 elaboratedPlan'
387 let elaboratedPlan'' =
388 improveInstallPlanWithUpToDatePackages
389 pkgsBuildStatus
390 elaboratedPlan'
391 debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'')
394 buildCtx =
395 ProjectBuildContext
396 { elaboratedPlanOriginal = elaboratedPlan
397 , elaboratedPlanToExecute = elaboratedPlan''
398 , elaboratedShared = elaboratedShared'
399 , pkgsBuildStatus
400 , targetsMap = targets
403 ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared'
405 repl_flags = case originalComponent of
406 Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
407 Nothing -> []
409 return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets)
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'
423 let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
424 printPlan verbosity baseCtx'' buildCtx'
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
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")
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
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
443 -- ghc program with overriden PATH
444 (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx'))
445 let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]}
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
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
471 render_j Serial = "1"
472 render_j (UseSem n) = show @Int n
473 render_j (NumJobs mn) = maybe "" (show @Int) mn
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))
485 : [ ["-unit", "@" ++ dir </> unit]
486 | unit <- unit_files_ordered
487 , unit /= "paths"
490 pure ()
491 else do
492 -- single target repl
493 replOpts'' <- case targetCtx of
494 ProjectContext -> return replOpts'
495 _ -> usingGhciScript compiler projectRoot replOpts'
497 let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
498 printPlan verbosity baseCtx'' buildCtx'
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
509 verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
510 tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags
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
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]
533 return targets
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
547 -- | First version of GHC which supports multiple home packages
548 minMultipleHomeUnitsVersion :: Version
549 minMultipleHomeUnitsVersion = mkVersion [9, 4]
551 data OriginalComponentInfo = OriginalComponentInfo
552 { ociUnitId :: UnitId
553 , ociOriginalDeps :: [UnitId]
555 deriving (Show)
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 $
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 ++)
583 addDeps spec = spec
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])
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'
604 -- | Add repl options to ensure the repl actually starts in the current working directory.
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.
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
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]
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.
630 -- For repl we select:
632 -- * the library if there is only one and it's buildable; or
634 -- * the exe if there is only one and it's buildable; or
636 -- * any other buildable component.
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
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
666 selectBuildableTargetsWith'
667 (isRequested targetSelector)
668 targets
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
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'
715 selectBuildableTargets'
716 . filterTargetsKind LibKind
717 $ targets
718 ( targetsExesBuildable
719 , targetsExesBuildable'
721 selectBuildableTargets'
722 . filterTargetsKind ExeKind
723 $ targets
724 ( targetsBuildable
725 , targetsBuildable'
727 selectBuildableTargetsWith'
728 (isRequested targetSelector)
729 targets
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
738 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
739 -- selected.
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
748 data ReplProblem
749 = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()]
750 | -- | Multiple 'TargetSelector's match multiple targets
751 TargetProblemMultipleTargets MultiReplDecision TargetsMap
752 deriving (Eq, Show)
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
758 matchesMultipleProblem
759 :: MultiReplDecision
760 -> TargetSelector
761 -> [AvailableTarget ()]
762 -> ReplTargetProblem
763 matchesMultipleProblem decision targetSelector targetsExesBuildable =
764 CustomTargetProblem $ TargetProblemMatchesMultiple decision targetSelector targetsExesBuildable
766 multipleTargetsProblem
767 :: MultiReplDecision
768 -> TargetsMap
769 -> ReplTargetProblem
770 multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision
772 reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
773 reportTargetProblems verbosity =
774 dieWithException verbosity . RenderReplTargetProblem . map renderReplTargetProblem
776 renderReplTargetProblem :: TargetProblem ReplProblem -> String
777 renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem
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)
797 | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets
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
811 ++ " refer to different components."
812 ++ ".\n\n"
813 ++ explainMultiReplDecision multi_decision
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"
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"
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 ++ ") "
848 -- Lenses
849 lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
850 lElaboratedShared f s = fmap (\x -> s{elaboratedShared = x}) (f (elaboratedShared s))
851 {-# INLINE lElaboratedShared #-}
853 lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions
854 lPkgConfigReplOptions f s = fmap (\x -> s{pkgConfigReplOptions = x}) (f (pkgConfigReplOptions s))
855 {-# INLINE lPkgConfigReplOptions #-}
857 lReplOptionsFlags :: Lens' ReplOptions [String]
858 lReplOptionsFlags f s = fmap (\x -> s{replOptionsFlags = x}) (f (replOptionsFlags s))
859 {-# INLINE lReplOptionsFlags #-}
861 lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
862 lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s))
863 {-# INLINE lProjectConfig #-}
865 lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared
866 lProjectConfigShared f s = fmap (\x -> s{projectConfigShared = x}) (f (projectConfigShared s))
867 {-# INLINE lProjectConfigShared #-}
869 lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]
870 lProjectConfigConstraints f s = fmap (\x -> s{projectConfigConstraints = x}) (f (projectConfigConstraints s))
871 {-# INLINE lProjectConfigConstraints #-}