1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RecordWildCards #-}
6
7-- | cabal-install CLI command: repl
8--
9module Distribution.Client.CmdRepl (
10    -- * The @repl@ CLI and action
11    replCommand,
12    replAction,
13
14    -- * Internals exposed for testing
15    TargetProblem(..),
16    selectPackageTargets,
17    selectComponentTarget
18  ) where
19
20import Prelude ()
21import Distribution.Client.Compat.Prelude
22
23import Distribution.Compat.Lens
24import qualified Distribution.Types.Lens as L
25
26import Distribution.Client.CmdErrorMessages
27import Distribution.Client.CmdInstall
28         ( establishDummyProjectBaseContext )
29import qualified Distribution.Client.InstallPlan as InstallPlan
30import Distribution.Client.ProjectBuilding
31         ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )
32import Distribution.Client.ProjectConfig
33         ( ProjectConfig(..), withProjectOrGlobalConfigIgn
34         , projectConfigConfigFile )
35import Distribution.Client.ProjectOrchestration
36import Distribution.Client.ProjectPlanning
37       ( ElaboratedSharedConfig(..), ElaboratedInstallPlan )
38import Distribution.Client.ProjectPlanning.Types
39       ( elabOrderExeDependencies )
40import Distribution.Client.Setup
41         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
42import qualified Distribution.Client.Setup as Client
43import Distribution.Client.Types
44         ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
45import Distribution.Simple.Setup
46         ( HaddockFlags, TestFlags, BenchmarkFlags
47         , fromFlagOrDefault, replOptions
48         , Flag(..), toFlag, trueArg, falseArg )
49import Distribution.Simple.Command
50         ( CommandUI(..), liftOption, usageAlternatives, option
51         , ShowOrParseArgs, OptionField, reqArg )
52import Distribution.Compiler
53         ( CompilerFlavor(GHC) )
54import Distribution.Simple.Compiler
55         ( compilerCompatVersion )
56import Distribution.Package
57         ( Package(..), packageName, UnitId, installedUnitId )
58import Distribution.PackageDescription.PrettyPrint
59import Distribution.Parsec
60         ( Parsec(..), parsecCommaList )
61import Distribution.Pretty
62         ( prettyShow )
63import Distribution.ReadE
64         ( ReadE, parsecToReadE )
65import qualified Distribution.SPDX.License as SPDX
66import Distribution.Solver.Types.SourcePackage
67         ( SourcePackage(..) )
68import Distribution.Types.BuildInfo
69         ( BuildInfo(..), emptyBuildInfo )
70import Distribution.Types.ComponentName
71         ( componentNameString )
72import Distribution.Types.CondTree
73         ( CondTree(..), traverseCondTreeC )
74import Distribution.Types.Dependency
75         ( Dependency(..) )
76import Distribution.Types.GenericPackageDescription
77         ( emptyGenericPackageDescription )
78import Distribution.Types.LibraryName
79         ( LibraryName(..) )
80import Distribution.Types.PackageDescription
81         ( PackageDescription(..), emptyPackageDescription )
82import Distribution.Types.PackageName.Magic
83         ( fakePackageId )
84import Distribution.Types.Library
85         ( Library(..), emptyLibrary )
86import Distribution.Types.Version
87         ( mkVersion )
88import Distribution.Types.VersionRange
89         ( anyVersion )
90import Distribution.Deprecated.Text
91         ( display )
92import Distribution.Utils.Generic
93         ( safeHead )
94import Distribution.Verbosity
95         ( Verbosity, normal, lessVerbose )
96import Distribution.Simple.Utils
97         ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist )
98import Language.Haskell.Extension
99         ( Language(..) )
100
101import Data.List
102         ( (\\) )
103import qualified Data.Map as Map
104import qualified Data.Set as Set
105import System.Directory
106         ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive )
107import System.FilePath
108         ( (</>) )
109
110type ReplFlags = [String]
111
112data EnvFlags = EnvFlags
113  { envPackages :: [Dependency]
114  , envIncludeTransitive :: Flag Bool
115  , envIgnoreProject :: Flag Bool
116  }
117
118defaultEnvFlags :: EnvFlags
119defaultEnvFlags = EnvFlags
120  { envPackages = []
121  , envIncludeTransitive = toFlag True
122  , envIgnoreProject = toFlag False
123  }
124
125envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
126envOptions _ =
127  [ option ['b'] ["build-depends"]
128    "Include an additional package in the environment presented to GHCi."
129    envPackages (\p flags -> flags { envPackages = p ++ envPackages flags })
130    (reqArg "DEPENDENCY" dependencyReadE (fmap prettyShow :: [Dependency] -> [String]))
131  , option [] ["no-transitive-deps"]
132    "Don't automatically include transitive dependencies of requested packages."
133    envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })
134    falseArg
135  , option ['z'] ["ignore-project"]
136    "Only include explicitly specified packages (and 'base')."
137    envIgnoreProject (\p flags -> flags { envIgnoreProject = p })
138    trueArg
139  ]
140  where
141    dependencyReadE :: ReadE [Dependency]
142    dependencyReadE =
143      parsecToReadE
144        ("couldn't parse dependency: " ++)
145        (parsecCommaList parsec)
146
147replCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
148                         , HaddockFlags, TestFlags, BenchmarkFlags
149                         , ReplFlags, EnvFlags
150                         )
151replCommand = Client.installCommand {
152  commandName         = "v2-repl",
153  commandSynopsis     = "Open an interactive session for the given component.",
154  commandUsage        = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ],
155  commandDescription  = Just $ \_ -> wrapText $
156        "Open an interactive session for a component within the project. The "
157     ++ "available targets are the same as for the 'v2-build' command: "
158     ++ "individual components within packages in the project, including "
159     ++ "libraries, executables, test-suites or benchmarks. Packages can "
160     ++ "also be specified in which case the library component in the "
161     ++ "package will be used, or the (first listed) executable in the "
162     ++ "package if there is no library.\n\n"
163
164     ++ "Dependencies are built or rebuilt as necessary. Additional "
165     ++ "configuration flags can be specified on the command line and these "
166     ++ "extend the project configuration from the 'cabal.project', "
167     ++ "'cabal.project.local' and other files.",
168  commandNotes        = Just $ \pname ->
169        "Examples, open an interactive session:\n"
170     ++ "  " ++ pname ++ " v2-repl\n"
171     ++ "    for the default component in the package in the current directory\n"
172     ++ "  " ++ pname ++ " v2-repl pkgname\n"
173     ++ "    for the default component in the package named 'pkgname'\n"
174     ++ "  " ++ pname ++ " v2-repl ./pkgfoo\n"
175     ++ "    for the default component in the package in the ./pkgfoo directory\n"
176     ++ "  " ++ pname ++ " v2-repl cname\n"
177     ++ "    for the component named 'cname'\n"
178     ++ "  " ++ pname ++ " v2-repl pkgname:cname\n"
179     ++ "    for the component 'cname' in the package 'pkgname'\n\n"
180     ++ "  " ++ pname ++ " v2-repl --build-depends lens\n"
181     ++ "    add the latest version of the library 'lens' to the default component "
182        ++ "(or no componentif there is no project present)\n"
183     ++ "  " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
184     ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "
185        ++ "to the default component (or no component if there is no project present)\n"
186
187     ++ cmdCommonHelpTextNewBuildBeta,
188  commandDefaultFlags = ( configFlags, configExFlags, installFlags
189                        , haddockFlags, testFlags, benchmarkFlags
190                        , [], defaultEnvFlags
191                        ),
192  commandOptions = \showOrParseArgs ->
193        map liftOriginal (commandOptions Client.installCommand showOrParseArgs)
194        ++ map liftReplOpts (replOptions showOrParseArgs)
195        ++ map liftEnvOpts  (envOptions  showOrParseArgs)
196   }
197  where
198    (configFlags,configExFlags,installFlags,haddockFlags,testFlags,benchmarkFlags)
199      = commandDefaultFlags Client.installCommand
200
201    liftOriginal = liftOption projectOriginal updateOriginal
202    liftReplOpts = liftOption projectReplOpts updateReplOpts
203    liftEnvOpts  = liftOption projectEnvOpts  updateEnvOpts
204
205    projectOriginal              (a,b,c,d,e,f,_,_) = (a,b,c,d,e,f)
206    updateOriginal (a,b,c,d,e,f) (_,_,_,_,_,_,g,h) = (a,b,c,d,e,f,g,h)
207
208    projectReplOpts  (_,_,_,_,_,_,g,_) = g
209    updateReplOpts g (a,b,c,d,e,f,_,h) = (a,b,c,d,e,f,g,h)
210
211    projectEnvOpts  (_,_,_,_,_,_,_,h) = h
212    updateEnvOpts h (a,b,c,d,e,f,g,_) = (a,b,c,d,e,f,g,h)
213
214-- | The @repl@ command is very much like @build@. It brings the install plan
215-- up to date, selects that part of the plan needed by the given or implicit
216-- repl target and then executes the plan.
217--
218-- Compared to @build@ the difference is that only one target is allowed
219-- (given or implicit) and the target type is repl rather than build. The
220-- general plan execution infrastructure handles both build and repl targets.
221--
222-- For more details on how this works, see the module
223-- "Distribution.Client.ProjectOrchestration"
224--
225replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
226              , HaddockFlags, TestFlags, BenchmarkFlags
227              , ReplFlags, EnvFlags )
228           -> [String] -> GlobalFlags -> IO ()
229replAction ( configFlags, configExFlags, installFlags
230           , haddockFlags, testFlags, benchmarkFlags
231           , replFlags, envFlags )
232           targetStrings globalFlags = do
233    let
234      ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags)
235      with           = withProject    cliConfig             verbosity targetStrings
236      without config = withoutProject (config <> cliConfig) verbosity targetStrings
237
238    (baseCtx, targetSelectors, finalizer, replType) <-
239      withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without
240
241    when (buildSettingOnlyDeps (buildSettings baseCtx)) $
242      die' verbosity $ "The repl command does not support '--only-dependencies'. "
243          ++ "You may wish to use 'build --only-dependencies' and then "
244          ++ "use 'repl'."
245
246    (originalComponent, baseCtx') <- if null (envPackages envFlags)
247      then return (Nothing, baseCtx)
248      else
249        -- Unfortunately, the best way to do this is to let the normal solver
250        -- help us resolve the targets, but that isn't ideal for performance,
251        -- especially in the no-project case.
252        withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do
253          -- targets should be non-empty map, but there's no NonEmptyMap yet.
254          targets <- validatedTargets elaboratedPlan targetSelectors
255
256          let
257            (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
258            originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId
259            oci = OriginalComponentInfo unitId originalDeps
260            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId
261            baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx
262
263          return (Just oci, baseCtx')
264
265    -- Now, we run the solver again with the added packages. While the graph
266    -- won't actually reflect the addition of transitive dependencies,
267    -- they're going to be available already and will be offered to the REPL
268    -- and that's good enough.
269    --
270    -- In addition, to avoid a *third* trip through the solver, we are
271    -- replicating the second half of 'runProjectPreBuildPhase' by hand
272    -- here.
273    (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $
274      \elaboratedPlan elaboratedShared' -> do
275        let ProjectBaseContext{..} = baseCtx'
276
277        -- Recalculate with updated project.
278        targets <- validatedTargets elaboratedPlan targetSelectors
279
280        let
281          elaboratedPlan' = pruneInstallPlanToTargets
282                              TargetActionRepl
283                              targets
284                              elaboratedPlan
285          includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags)
286
287        pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared'
288                                          elaboratedPlan'
289
290        let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages
291                                pkgsBuildStatus elaboratedPlan'
292        debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')
293
294        let
295          buildCtx = ProjectBuildContext
296            { elaboratedPlanOriginal = elaboratedPlan
297            , elaboratedPlanToExecute = elaboratedPlan''
298            , elaboratedShared = elaboratedShared'
299            , pkgsBuildStatus
300            , targetsMap = targets
301            }
302
303          ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared'
304
305          -- First version of GHC where GHCi supported the flag we need.
306          -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html
307          minGhciScriptVersion = mkVersion [7, 6]
308
309          replFlags' = case originalComponent of
310            Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
311            Nothing  -> []
312          replFlags'' = case replType of
313            GlobalRepl scriptPath
314              | Just version <- compilerCompatVersion GHC compiler
315              , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags'
316            _                                   -> replFlags'
317
318        return (buildCtx, replFlags'')
319
320    let buildCtx' = buildCtx
321          { elaboratedShared = (elaboratedShared buildCtx)
322                { pkgConfigReplOptions = replFlags ++ replFlags'' }
323          }
324    printPlan verbosity baseCtx' buildCtx'
325
326    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx'
327    runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes
328    finalizer
329  where
330    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
331    cliConfig = commandLineFlagsToProjectConfig
332                  globalFlags configFlags configExFlags
333                  installFlags
334                  mempty -- ClientInstallFlags, not needed here
335                  haddockFlags testFlags benchmarkFlags
336    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
337
338    validatedTargets elaboratedPlan targetSelectors = do
339      -- Interpret the targets on the command line as repl targets
340      -- (as opposed to say build or haddock targets).
341      targets <- either (reportTargetProblems verbosity) return
342          $ resolveTargets
343              selectPackageTargets
344              selectComponentTarget
345              TargetProblemCommon
346              elaboratedPlan
347              Nothing
348              targetSelectors
349
350      -- Reject multiple targets, or at least targets in different
351      -- components. It is ok to have two module/file targets in the
352      -- same component, but not two that live in different components.
353      when (Set.size (distinctTargetComponents targets) > 1) $
354        reportTargetProblems verbosity
355          [TargetProblemMultipleTargets targets]
356
357      return targets
358
359data OriginalComponentInfo = OriginalComponentInfo
360  { ociUnitId :: UnitId
361  , ociOriginalDeps :: [UnitId]
362  }
363  deriving (Show)
364
365-- | Tracks what type of GHCi instance we're creating.
366data ReplType = ProjectRepl
367              | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi
368                                    --   script responsible for changing to the
369                                    --   correct directory. Only works on GHC geq
370                                    --   7.6, though. ��
371              deriving (Show, Eq)
372
373withProject :: ProjectConfig -> Verbosity -> [String]
374            -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)
375withProject cliConfig verbosity targetStrings = do
376  baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
377
378  targetSelectors <- either (reportTargetSelectorProblems verbosity) return
379                 =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings
380
381  return (baseCtx, targetSelectors, return (), ProjectRepl)
382
383withoutProject :: ProjectConfig -> Verbosity -> [String]
384               -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)
385withoutProject config verbosity extraArgs = do
386  unless (null extraArgs) $
387    die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs
388
389  globalTmp <- getTemporaryDirectory
390  tempDir <- createTempDirectory globalTmp "cabal-repl."
391
392  -- We need to create a dummy package that lives in our dummy project.
393  let
394    sourcePackage = SourcePackage
395      { packageInfoId        = pkgId
396      , packageDescription   = genericPackageDescription
397      , packageSource        = LocalUnpackedPackage tempDir
398      , packageDescrOverride = Nothing
399      }
400    genericPackageDescription = emptyGenericPackageDescription
401      & L.packageDescription .~ packageDescription
402      & L.condLibrary        .~ Just (CondNode library [baseDep] [])
403    packageDescription = emptyPackageDescription
404      { package = pkgId
405      , specVersionRaw = Left (mkVersion [2, 2])
406      , licenseRaw = Left SPDX.NONE
407      }
408    library = emptyLibrary { libBuildInfo = buildInfo }
409    buildInfo = emptyBuildInfo
410      { targetBuildDepends = [baseDep]
411      , defaultLanguage = Just Haskell2010
412      }
413    baseDep = Dependency "base" anyVersion (Set.singleton LMainLibName)
414    pkgId = fakePackageId
415
416  writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription
417
418  let ghciScriptPath = tempDir </> "setcwd.ghci"
419  cwd <- getCurrentDirectory
420  writeFile ghciScriptPath (":cd " ++ cwd)
421
422  baseCtx <-
423    establishDummyProjectBaseContext
424      verbosity
425      config
426      tempDir
427      [SpecificSourcePackage sourcePackage]
428      OtherCommand
429
430  let
431    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]
432    finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir)
433
434  return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath)
435
436addDepsToProjectTarget :: [Dependency]
437                       -> PackageId
438                       -> ProjectBaseContext
439                       -> ProjectBaseContext
440addDepsToProjectTarget deps pkgId ctx =
441    (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx
442  where
443    addDeps :: PackageSpecifier UnresolvedSourcePackage
444            -> PackageSpecifier UnresolvedSourcePackage
445    addDeps (SpecificSourcePackage pkg)
446      | packageId pkg /= pkgId = SpecificSourcePackage pkg
447      | SourcePackage{..} <- pkg =
448        SpecificSourcePackage $ pkg { packageDescription =
449          packageDescription & (\f -> L.allCondTrees $ traverseCondTreeC f)
450                            %~ (deps ++)
451        }
452    addDeps spec = spec
453
454generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags
455generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags
456  where
457    exeDeps :: [UnitId]
458    exeDeps =
459      foldMap
460        (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)
461        (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])
462
463    deps, deps', trans, trans' :: [UnitId]
464    flags :: ReplFlags
465    deps   = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
466    deps'  = deps \\ ociOriginalDeps
467    trans  = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
468    trans' = trans \\ ociOriginalDeps
469    flags  = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps)
470      $ if includeTransitive then trans' else deps'
471
472-- | This defines what a 'TargetSelector' means for the @repl@ command.
473-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
474-- or otherwise classifies the problem.
475--
476-- For repl we select:
477--
478-- * the library if there is only one and it's buildable; or
479--
480-- * the exe if there is only one and it's buildable; or
481--
482-- * any other buildable component.
483--
484-- Fail if there are no buildable lib\/exe components, or if there are
485-- multiple libs or exes.
486--
487selectPackageTargets  :: TargetSelector
488                      -> [AvailableTarget k] -> Either TargetProblem [k]
489selectPackageTargets targetSelector targets
490
491    -- If there is exactly one buildable library then we select that
492  | [target] <- targetsLibsBuildable
493  = Right [target]
494
495    -- but fail if there are multiple buildable libraries.
496  | not (null targetsLibsBuildable)
497  = Left (TargetProblemMatchesMultiple targetSelector targetsLibsBuildable')
498
499    -- If there is exactly one buildable executable then we select that
500  | [target] <- targetsExesBuildable
501  = Right [target]
502
503    -- but fail if there are multiple buildable executables.
504  | not (null targetsExesBuildable)
505  = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable')
506
507    -- If there is exactly one other target then we select that
508  | [target] <- targetsBuildable
509  = Right [target]
510
511    -- but fail if there are multiple such targets
512  | not (null targetsBuildable)
513  = Left (TargetProblemMatchesMultiple targetSelector targetsBuildable')
514
515    -- If there are targets but none are buildable then we report those
516  | not (null targets)
517  = Left (TargetProblemNoneEnabled targetSelector targets')
518
519    -- If there are no targets at all then we report that
520  | otherwise
521  = Left (TargetProblemNoTargets targetSelector)
522  where
523    targets'                = forgetTargetsDetail targets
524    (targetsLibsBuildable,
525     targetsLibsBuildable') = selectBuildableTargets'
526                            . filterTargetsKind LibKind
527                            $ targets
528    (targetsExesBuildable,
529     targetsExesBuildable') = selectBuildableTargets'
530                            . filterTargetsKind ExeKind
531                            $ targets
532    (targetsBuildable,
533     targetsBuildable')     = selectBuildableTargetsWith'
534                                (isRequested targetSelector) targets
535
536    -- When there's a target filter like "pkg:tests" then we do select tests,
537    -- but if it's just a target like "pkg" then we don't build tests unless
538    -- they are requested by default (i.e. by using --enable-tests)
539    isRequested (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False
540    isRequested (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False
541    isRequested _ _ = True
542
543
544-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
545-- selected.
546--
547-- For the @repl@ command we just need the basic checks on being buildable etc.
548--
549selectComponentTarget :: SubComponentTarget
550                      -> AvailableTarget k -> Either TargetProblem k
551selectComponentTarget subtarget =
552    either (Left . TargetProblemCommon) Right
553  . selectComponentTargetBasic subtarget
554
555
556-- | The various error conditions that can occur when matching a
557-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.
558--
559data TargetProblem =
560     TargetProblemCommon       TargetProblemCommon
561
562     -- | The 'TargetSelector' matches targets but none are buildable
563   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
564
565     -- | There are no targets at all
566   | TargetProblemNoTargets   TargetSelector
567
568     -- | A single 'TargetSelector' matches multiple targets
569   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
570
571     -- | Multiple 'TargetSelector's match multiple targets
572   | TargetProblemMultipleTargets TargetsMap
573  deriving (Eq, Show)
574
575reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
576reportTargetProblems verbosity =
577    die' verbosity . unlines . map renderTargetProblem
578
579renderTargetProblem :: TargetProblem -> String
580renderTargetProblem (TargetProblemCommon problem) =
581    renderTargetProblemCommon "open a repl for" problem
582
583renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) =
584    "Cannot open a repl for multiple components at once. The target '"
585 ++ showTargetSelector targetSelector ++ "' refers to "
586 ++ renderTargetSelector targetSelector ++ " which "
587 ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ")
588 ++ renderListSemiAnd
589      [ "the " ++ renderComponentKind Plural ckind ++ " " ++
590        renderListCommaAnd
591          [ maybe (display pkgname) display (componentNameString cname)
592          | t <- ts
593          , let cname   = availableTargetComponentName t
594                pkgname = packageName (availableTargetPackageId t)
595          ]
596      | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets
597      ]
598 ++ ".\n\n" ++ explanationSingleComponentLimitation
599  where
600    availableTargetComponentKind = componentKind
601                                 . availableTargetComponentName
602
603renderTargetProblem (TargetProblemMultipleTargets selectorMap) =
604    "Cannot open a repl for multiple components at once. The targets "
605 ++ renderListCommaAnd
606      [ "'" ++ showTargetSelector ts ++ "'"
607      | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]
608 ++ " refer to different components."
609 ++ ".\n\n" ++ explanationSingleComponentLimitation
610
611renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
612    renderTargetProblemNoneEnabled "open a repl for" targetSelector targets
613
614renderTargetProblem (TargetProblemNoTargets targetSelector) =
615    renderTargetProblemNoTargets "open a repl for" targetSelector
616
617
618explanationSingleComponentLimitation :: String
619explanationSingleComponentLimitation =
620    "The reason for this limitation is that current versions of ghci do not "
621 ++ "support loading multiple components as source. Load just one component "
622 ++ "and when you make changes to a dependent component then quit and reload."
623
624