From 9f653d52399770129b473d263ddd22ffef0b4d33 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 4 Nov 2024 11:50:07 -0800 Subject: [PATCH] aklsdgjlk --- .../Solver/Types/WithConstraintSource.hs | 2 +- .../src/Distribution/Client/CmdInstall.hs | 40 +- .../src/Distribution/Client/CmdListBin.hs | 12 +- .../src/Distribution/Client/CmdRepl.hs | 436 +++++++++--------- .../src/Distribution/Client/CmdRun.hs | 314 +++++++------ .../src/Distribution/Client/CmdSdist.hs | 53 ++- .../src/Distribution/Client/Errors.hs | 7 +- .../src/Distribution/Client/ScriptUtils.hs | 49 +- .../src/Distribution/Client/TargetSelector.hs | 19 +- project-cabal/ghc-options.config | 2 + 10 files changed, 500 insertions(+), 434 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs index 026d6c2589d..9f0fb0a563a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs @@ -45,4 +45,4 @@ instance Pretty pkg => Pretty (WithConstraintSource pkg) where = pretty constraintPackage pretty (WithConstraintSource { constraintPackage, constraintConstraint }) = pretty constraintPackage - <+> parens (text $ showConstraintSource constraintConstraint) + <+> parens (text "from" <+> pretty constraintConstraint) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 73bb412d16f..8acbf990863 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -265,7 +265,7 @@ type InstallAction = Verbosity -> OverwritePolicy -> InstallExe - -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) + -> (UnitId, [(ComponentTarget, NonEmpty (WithConstraintSource TargetSelector))]) -> IO () data InstallCfg = InstallCfg @@ -610,7 +610,7 @@ withProject verbosity cliConfig targetStrings installLibs = do -- We want to apply the local configuration only to the actual targets. let config = addLocalConfigToPkgs (projectConfig baseCtx) $ - concatMap (targetPkgNames $ localPackages baseCtx) targetSelectors + concatMap (targetPkgNames (localPackages baseCtx) . constraintPackage) targetSelectors return (pkgSpecs, targetSelectors, config) where reducedVerbosity = lessVerbose verbosity @@ -663,7 +663,7 @@ resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targe targetSelectors <- readTargetSelectors (localPackages baseCtx) Nothing targetStrings >>= \case - Left problems -> reportTargetSelectorProblems verbosity problems + Left problems -> reportTargetSelectorProblems verbosity (map constraintPackage problems) Right ts -> return ts getSpecsAndTargetSelectors @@ -714,7 +714,7 @@ withoutProject verbosity globalConfig targetStrings = do buildSettings (getSourcePackages verbosity) - for_ (concatMap woPackageNames tss) $ \name -> do + for_ (concatMap (woPackageNames . constraintPackage) tss) $ \name -> do when (null (lookupPackageName packageIndex name)) $ do let xs = searchByName packageIndex (unPackageName name) let emptyIf True _ = [] @@ -728,14 +728,20 @@ withoutProject verbosity globalConfig targetStrings = do dieWithException verbosity $ WithoutProject (unPackageName name) str2 let - packageSpecifiers :: [PackageSpecifier UnresolvedSourcePackage] - (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss - packageTargets = map woPackageTargets tss + outerEither :: WithConstraintSource (Either a b) -> Either (WithConstraintSource a) (WithConstraintSource b) + outerEither (withConstraint@WithConstraintSource{constraintPackage = either'}) = + case either' of + Left inner -> Left (withConstraint{constraintPackage=inner}) + Right inner -> Right (withConstraint{constraintPackage=inner}) + + packageSpecifiers :: [WithConstraintSource (PackageSpecifier UnresolvedSourcePackage)] + (uris, packageSpecifiers) = partitionEithers $ map (outerEither . fmap woPackageSpecifiers) tss + packageTargets = map (fmap woPackageTargets) tss -- Apply the local configuration (e.g. cli flags) to all direct targets of install command, -- see note in 'installAction' - let config = addLocalConfigToPkgs globalConfig (concatMap woPackageNames tss) - return (packageSpecifiers, uris, packageTargets, config) + let config = addLocalConfigToPkgs globalConfig (concatMap (woPackageNames . constraintPackage) tss) + return (map constraintPackage packageSpecifiers, uris, packageTargets, config) addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig addLocalConfigToPkgs config pkgs = @@ -790,11 +796,11 @@ getSpecsAndTargetSelectors :: Verbosity -> Verbosity -> SourcePackageDb - -> [TargetSelector] + -> [WithConstraintSource TargetSelector] -> DistDirLayout -> ProjectBaseContext -> Maybe ComponentKindFilter - -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) + -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource TargetSelector]) getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelectors distDirLayout baseCtx targetFilter = withInstallPlan reducedVerbosity baseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. @@ -832,7 +838,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector localTargets = map gatherTargets (Map.keys targetsMap) hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] - hackagePkgs = [NamedPackage pn [] | pn <- hackageNames] + hackagePkgs = [Named (WithConstraintSource {constraintPackage=pn}) | pn <- hackageNames] hackageTargets :: [TargetSelector] hackageTargets = [TargetPackageNamed pn targetFilter | pn <- hackageNames] @@ -867,7 +873,7 @@ partitionToKnownTargetsAndHackagePackages :: Verbosity -> SourcePackageDb -> ElaboratedInstallPlan - -> [TargetSelector] + -> [WithConstraintSource TargetSelector] -> IO (TargetsMap, [PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do let mTargets = @@ -884,7 +890,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS Left errs -> do -- Not everything is local. let - (errs', hackageNames) = partitionEithers . flip fmap errs $ \case + (errs', hackageNames) = partitionEithers . flip fmap (map constraintPackage $ errs) $ \case TargetAvailableInIndex name -> Right name err -> Left err @@ -900,7 +906,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' let - targetSelectors' = flip filter targetSelectors $ \case + targetSelectors' = flip filter (map constraintPackage targetSelectors) $ \case TargetComponentUnknown name _ _ | name `elem` hackageNames -> False TargetPackageNamed name _ @@ -910,7 +916,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS -- This can't fail, because all of the errors are -- removed (or we've given up). targets <- - either (reportBuildTargetProblems verbosity) return $ + either (reportBuildTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget @@ -924,7 +930,7 @@ constructProjectBuildContext :: Verbosity -> ProjectBaseContext -- ^ The synthetic base context to use to produce the full build context. - -> [TargetSelector] + -> [WithConstraintSource TargetSelector] -> IO ProjectBuildContext constructProjectBuildContext verbosity baseCtx targetSelectors = do runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index e53100122e9..aa1acbe9070 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -64,6 +64,8 @@ import Distribution.Client.Errors import qualified Distribution.Client.InstallPlan as IP import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource(..)) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) ------------------------------------------------------------------------------- -- Command @@ -96,8 +98,14 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do [x] -> return x _ -> dieWithException verbosity OneTargetRequired + let targetProvenance = + WithConstraintSource + { constraintPackage = target + , constraintConstraint = ConstraintSourceCommandlineFlag + } + -- configure and elaborate target selectors - withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do + withContextAndSelectors RejectNoTargets (Just ExeKind) flags [targetProvenance] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do baseCtx <- case targetCtx of ProjectContext -> return ctx GlobalContext -> return ctx @@ -108,7 +116,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- Interpret the targets on the command line as build targets -- (as opposed to say repl or haddock targets). targets <- - either (reportTargetProblems verbosity) return $ + either (reportTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 0877454a1c7..7fbd4f8564f 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -113,7 +113,7 @@ import Distribution.Simple.Utils , wrapText ) import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource (ConstraintSourceMultiRepl) + ( ConstraintSource (..) ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (PackagePropertyVersion) @@ -288,220 +288,230 @@ multiReplDecision ctx compiler flags = -- "Distribution.Client.ProjectOrchestration" replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO () replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags = - withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do - when (buildSettingOnlyDeps (buildSettings ctx)) $ - dieWithException verbosity ReplCommandDoesn'tSupport - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - distDir = distDirectory $ distDirLayout ctx - - baseCtx <- case targetCtx of - ProjectContext -> return ctx - GlobalContext -> do - unless (null targetStrings) $ - dieWithException verbosity $ - ReplTakesNoArguments targetStrings - let - sourcePackage = - fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condLibrary - .~ Just (CondNode library [baseDep] []) - library = emptyLibrary{libBuildInfo = lBuildInfo} - lBuildInfo = - emptyBuildInfo - { targetBuildDepends = [baseDep] - , defaultLanguage = Just Haskell2010 - } - baseDep = Dependency "base" anyVersion mainLibSet - - updateContextAndWriteProjectFile' ctx sourcePackage - ScriptContext scriptPath scriptExecutable -> do - unless (length targetStrings == 1) $ - dieWithException verbosity $ - ReplTakesSingleArgument targetStrings - existsScriptPath <- doesFileExist scriptPath - unless existsScriptPath $ - dieWithException verbosity $ - ReplTakesSingleArgument targetStrings - - updateContextAndWriteProjectFile ctx scriptPath scriptExecutable - - -- If multi-repl is used, we need a Cabal recent enough to handle it. - -- We need to do this before solving, but the compiler version is only known - -- after solving (phaseConfigureCompiler), so instead of using - -- multiReplDecision we just check the flag. - let baseCtx' = - if fromFlagOrDefault False $ - projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx) - <> replUseMulti - then - baseCtx - & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints - %~ (multiReplCabalConstraint :) - else baseCtx - - (originalComponent, baseCtx'') <- - if null (envPackages replEnvFlags) - then return (Nothing, baseCtx') - else -- Unfortunately, the best way to do this is to let the normal solver - -- help us resolve the targets, but that isn't ideal for performance, - -- especially in the no-project case. - withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do - -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + withContextAndSelectors + AcceptNoTargets + (Just LibKind) + flags + ( map + (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) + targetStrings + ) + globalFlags + ReplCommand + $ \targetCtx ctx targetSelectors -> do + when (buildSettingOnlyDeps (buildSettings ctx)) $ + dieWithException verbosity ReplCommandDoesn'tSupport + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + distDir = distDirectory $ distDirLayout ctx + + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> do + unless (null targetStrings) $ + dieWithException verbosity $ + ReplTakesNoArguments targetStrings + let + sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condLibrary + .~ Just (CondNode library [baseDep] []) + library = emptyLibrary{libBuildInfo = lBuildInfo} + lBuildInfo = + emptyBuildInfo + { targetBuildDepends = [baseDep] + , defaultLanguage = Just Haskell2010 + } + baseDep = Dependency "base" anyVersion mainLibSet + + updateContextAndWriteProjectFile' ctx sourcePackage + ScriptContext scriptPath scriptExecutable -> do + unless (length targetStrings == 1) $ + dieWithException verbosity $ + ReplTakesSingleArgument targetStrings + existsScriptPath <- doesFileExist scriptPath + unless existsScriptPath $ + dieWithException verbosity $ + ReplTakesSingleArgument targetStrings + + updateContextAndWriteProjectFile ctx scriptPath scriptExecutable + + -- If multi-repl is used, we need a Cabal recent enough to handle it. + -- We need to do this before solving, but the compiler version is only known + -- after solving (phaseConfigureCompiler), so instead of using + -- multiReplDecision we just check the flag. + let baseCtx' = + if fromFlagOrDefault False $ + projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx) + <> replUseMulti + then + baseCtx + & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints + %~ (multiReplCabalConstraint :) + else baseCtx + + (originalComponent, baseCtx'') <- + if null (envPackages replEnvFlags) + then return (Nothing, baseCtx') + else -- Unfortunately, the best way to do this is to let the normal solver + -- help us resolve the targets, but that isn't ideal for performance, + -- especially in the no-project case. + withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do + -- targets should be non-empty map, but there's no NonEmptyMap yet. + targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + + let + (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets + originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId + oci = OriginalComponentInfo unitId originalDeps + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId + baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' + + return (Just oci, baseCtx'') + + -- Now, we run the solver again with the added packages. While the graph + -- won't actually reflect the addition of transitive dependencies, + -- they're going to be available already and will be offered to the REPL + -- and that's good enough. + -- + -- In addition, to avoid a *third* trip through the solver, we are + -- replicating the second half of 'runProjectPreBuildPhase' by hand + -- here. + (buildCtx, compiler, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ + \elaboratedPlan elaboratedShared' -> do + let ProjectBaseContext{..} = baseCtx'' + + -- Recalculate with updated project. + targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors let - (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets - originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId - oci = OriginalComponentInfo unitId originalDeps - pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId - baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' - - return (Just oci, baseCtx'') - - -- Now, we run the solver again with the added packages. While the graph - -- won't actually reflect the addition of transitive dependencies, - -- they're going to be available already and will be offered to the REPL - -- and that's good enough. - -- - -- In addition, to avoid a *third* trip through the solver, we are - -- replicating the second half of 'runProjectPreBuildPhase' by hand - -- here. - (buildCtx, compiler, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ - \elaboratedPlan elaboratedShared' -> do - let ProjectBaseContext{..} = baseCtx'' - - -- Recalculate with updated project. - targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors - - let - elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) - - pkgsBuildStatus <- - rebuildTargetsDryRun - distDirLayout - elaboratedShared' - elaboratedPlan' - - let elaboratedPlan'' = - improveInstallPlanWithUpToDatePackages - pkgsBuildStatus - elaboratedPlan' - debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'') - - let - buildCtx = - ProjectBuildContext - { elaboratedPlanOriginal = elaboratedPlan - , elaboratedPlanToExecute = elaboratedPlan'' - , elaboratedShared = elaboratedShared' - , pkgsBuildStatus - , targetsMap = targets - } + elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) + + pkgsBuildStatus <- + rebuildTargetsDryRun + distDirLayout + elaboratedShared' + elaboratedPlan' + + let elaboratedPlan'' = + improveInstallPlanWithUpToDatePackages + pkgsBuildStatus + elaboratedPlan' + debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'') - ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared' - - repl_flags = case originalComponent of - Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci - Nothing -> [] - - return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) - - -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for - -- a high-level overview about how everything fits together. - if Set.size (distinctTargetComponents targets) > 1 - then withTempDirectoryEx verbosity (TempFileOptions keepTempFiles) distDir "multi-out" $ \dir' -> do - -- multi target repl - dir <- makeAbsolute dir' - -- Modify the replOptions so that the ./Setup repl command will write options - -- into the multi-out directory. - replOpts'' <- case targetCtx of - ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir} - _ -> usingGhciScript compiler projectRoot replOpts' - - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx'' buildCtx' - - -- The project build phase will call `./Setup repl` but write the options - -- out into a file without starting a repl. - buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' - runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes - - -- calculate PATH, we construct a PATH which is the union of all paths from - -- the units which have been loaded. This is not quite right but usually works fine. - path_files <- listDirectory (dir "paths") - - -- Note: decode is partial. Should we use Structured here? - -- This might blow up with @build-type: Custom@ stuff. - ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files - - let all_paths = concatMap programOverrideEnv ghcProgs - let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) - -- HACK: Just combine together all env overrides, placing the most common things last - - -- ghc program with overriden PATH - (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) - let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} - - -- Find what the unit files are, and start a repl based on all the response - -- files which have been created in the directory. - -- unit files for components - unit_files <- listDirectory dir - - -- Order the unit files so that the find target becomes the active unit - let active_unit_fp :: Maybe FilePath - active_unit_fp = do - -- Get the first target selectors from the cli - activeTarget <- safeHead targetSelectors - -- Lookup the targets :: Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] - unitId <- - Map.toList targets - -- Keep the UnitId matching the desired target selector - & find (\(_, xs) -> any (\(_, selectors) -> activeTarget `elem` selectors) xs) - & fmap fst - -- Convert to filename (adapted from 'storePackageDirectory') - pure (prettyShow unitId) - unit_files_ordered :: [FilePath] - unit_files_ordered = - let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files - in -- GHC considers the last unit passed to be the active one - other_units ++ active_unit_files - - render_j Serial = "1" - render_j (UseSem n) = show @Int n - render_j (NumJobs mn) = maybe "" (show @Int) mn - - -- run ghc --interactive with - runProgramInvocation verbosity $ - programInvocation ghcProg' $ - concat $ - [ "--interactive" - , "-package-env" - , "-" -- to ignore ghc.environment.* files - , "-j" - , render_j (buildSettingNumJobs (buildSettings ctx)) - ] - : [ ["-unit", "@" ++ dir unit] - | unit <- unit_files_ordered - , unit /= "paths" - ] - - pure () - else do - -- single target repl - replOpts'' <- case targetCtx of - ProjectContext -> return replOpts' - _ -> usingGhciScript compiler projectRoot replOpts' - - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx'' buildCtx' - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' - runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes + let + buildCtx = + ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared = elaboratedShared' + , pkgsBuildStatus + , targetsMap = targets + } + + ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared' + + repl_flags = case originalComponent of + Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci + Nothing -> [] + + return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) + + -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for + -- a high-level overview about how everything fits together. + if Set.size (distinctTargetComponents targets) > 1 + then withTempDirectoryEx verbosity (TempFileOptions keepTempFiles) distDir "multi-out" $ \dir' -> do + -- multi target repl + dir <- makeAbsolute dir' + -- Modify the replOptions so that the ./Setup repl command will write options + -- into the multi-out directory. + replOpts'' <- case targetCtx of + ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir} + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx'' buildCtx' + + -- The project build phase will call `./Setup repl` but write the options + -- out into a file without starting a repl. + buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' + runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes + + -- calculate PATH, we construct a PATH which is the union of all paths from + -- the units which have been loaded. This is not quite right but usually works fine. + path_files <- listDirectory (dir "paths") + + -- Note: decode is partial. Should we use Structured here? + -- This might blow up with @build-type: Custom@ stuff. + ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files + + let all_paths = concatMap programOverrideEnv ghcProgs + let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) + -- HACK: Just combine together all env overrides, placing the most common things last + + -- ghc program with overriden PATH + (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} + + -- Find what the unit files are, and start a repl based on all the response + -- files which have been created in the directory. + -- unit files for components + unit_files <- listDirectory dir + + -- Order the unit files so that the find target becomes the active unit + let active_unit_fp :: Maybe FilePath + active_unit_fp = do + -- Get the first target selectors from the cli + activeTarget <- safeHead targetSelectors + -- Lookup the targets :: Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] + unitId <- + Map.toList targets + -- Keep the UnitId matching the desired target selector + & find (\(_, xs) -> any (\(_, selectors) -> activeTarget `elem` selectors) xs) + & fmap fst + -- Convert to filename (adapted from 'storePackageDirectory') + pure (prettyShow unitId) + unit_files_ordered :: [FilePath] + unit_files_ordered = + let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files + in -- GHC considers the last unit passed to be the active one + other_units ++ active_unit_files + + render_j Serial = "1" + render_j (UseSem n) = show @Int n + render_j (NumJobs mn) = maybe "" (show @Int) mn + + -- run ghc --interactive with + runProgramInvocation verbosity $ + programInvocation ghcProg' $ + concat $ + [ "--interactive" + , "-package-env" + , "-" -- to ignore ghc.environment.* files + , "-j" + , render_j (buildSettingNumJobs (buildSettings ctx)) + ] + : [ ["-unit", "@" ++ dir unit] + | unit <- unit_files_ordered + , unit /= "paths" + ] + + pure () + else do + -- single target repl + replOpts'' <- case targetCtx of + ProjectContext -> return replOpts' + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx'' buildCtx' + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' + runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes where combine_search_paths paths = foldl' go Map.empty paths @@ -517,7 +527,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). targets <- - either (reportTargetProblems verbosity) return $ + either (reportTargetProblems verbosity . map constraintPackage) return $ resolveTargets (selectPackageTargets multi_repl_enabled) selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 5c481ae1c76..d4ee7af2c30 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -114,6 +114,8 @@ import Distribution.Simple.Utils , wrapText ) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import Distribution.Types.ComponentName ( componentNameRaw ) @@ -208,159 +210,169 @@ runCommand = -- "Distribution.Client.ProjectOrchestration" runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = - withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do - (baseCtx, defaultVerbosity) <- case targetCtx of - ProjectContext -> return (ctx, normal) - GlobalContext -> return (ctx, normal) - ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta - - let verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags) - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - dieWithException verbosity NoSupportForRunCommand - - fullArgs <- getFullArgs - when (occursOnlyOrBefore fullArgs "+RTS" "--") $ - warn verbosity $ - giveRTSWarning "run" - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- - either (reportTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget + withContextAndSelectors + RejectNoTargets + (Just ExeKind) + flags + ( map + (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) + targetStr + ) + globalFlags + OtherCommand + $ \targetCtx ctx targetSelectors -> do + (baseCtx, defaultVerbosity) <- case targetCtx of + ProjectContext -> return (ctx, normal) + GlobalContext -> return (ctx, normal) + ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta + + let verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags) + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + dieWithException verbosity NoSupportForRunCommand + + fullArgs <- getFullArgs + when (occursOnlyOrBefore fullArgs "+RTS" "--") $ + warn verbosity $ + giveRTSWarning "run" + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportTargetProblems verbosity . map constraintPackage) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- + singleExeOrElse + ( reportTargetProblems + verbosity + [multipleTargetsProblem targets] + ) + targets + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleExeOrElse + ( dieWithException verbosity RunPhaseReached + ) + $ targetsMap buildCtx + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + let elaboratedPlan = elaboratedPlanToExecute buildCtx + matchingElaboratedConfiguredPackages = + matchingPackagesByUnitId + selectedUnitId elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- - singleExeOrElse - ( reportTargetProblems - verbosity - [multipleTargetsProblem targets] - ) - targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) - - (selectedUnitId, selectedComponent) <- - -- Slight duplication with 'runProjectPreBuildPhase'. - singleExeOrElse - ( dieWithException verbosity RunPhaseReached - ) - $ targetsMap buildCtx - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - - let elaboratedPlan = elaboratedPlanToExecute buildCtx - matchingElaboratedConfiguredPackages = - matchingPackagesByUnitId - selectedUnitId - elaboratedPlan - - let exeName = unUnqualComponentName selectedComponent - - -- In the common case, we expect @matchingElaboratedConfiguredPackages@ - -- to consist of a single element that provides a single way of building - -- an appropriately-named executable. In that case we take that - -- package and continue. - -- - -- However, multiple packages/components could provide that - -- executable, or it's possible we don't find the executable anywhere - -- in the build plan. I suppose in principle it's also possible that - -- a single package provides an executable in two different ways, - -- though that's probably a bug if. Anyway it's a good lint to report - -- an error in all of these cases, even if some seem like they - -- shouldn't happen. - pkg <- case matchingElaboratedConfiguredPackages of - [] -> dieWithException verbosity $ UnknownExecutable exeName selectedUnitId - [elabPkg] -> do - info verbosity $ - "Selecting " - ++ prettyShow selectedUnitId - ++ " to supply " - ++ exeName - return elabPkg - elabPkgs -> - dieWithException verbosity $ - MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - - let defaultExePath = - binDirectoryFor - (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName - exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) - - let dryRun = - buildSettingDryRun (buildSettings baseCtx) - || buildSettingOnlyDownload (buildSettings baseCtx) - - let - -- HACK alert: when doing a per-package build (e.g. with a Custom setup), - -- 'elabExeDependencyPaths' will not contain any internal executables - -- (they are deliberately filtered out; and even if they weren't, they have the wrong paths). - -- We add them back in here to ensure that any "build-tool-depends" of - -- the current executable is available in PATH at runtime. - internalToolDepsOfThisExe - | ElabPackage{} <- elabPkgOrComp pkg - , let pkg_descr = elabPkgDescription pkg - , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr - , let thisExeBI = PD.buildInfo thisExe = - [ binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg depExeNm - | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI - , let depExeNm = unUnqualComponentName depExe - ] - | otherwise = - [] - extraPath = - elabExeDependencyPaths pkg - ++ ( fromNubList - . projectConfigProgPathExtra - . projectConfigShared - . projectConfig - $ baseCtx - ) - ++ internalToolDepsOfThisExe - - logExtraProgramSearchPath verbosity extraPath - progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) - - if dryRun - then notice verbosity "Running of executable suppressed by flag(s)" - else - runProgramInvocation - verbosity - emptyProgramInvocation - { progInvokePath = exePath - , progInvokeArgs = args - , progInvokeEnv = - ("PATH", Just $ progPath) - : dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan - } + let exeName = unUnqualComponentName selectedComponent + + -- In the common case, we expect @matchingElaboratedConfiguredPackages@ + -- to consist of a single element that provides a single way of building + -- an appropriately-named executable. In that case we take that + -- package and continue. + -- + -- However, multiple packages/components could provide that + -- executable, or it's possible we don't find the executable anywhere + -- in the build plan. I suppose in principle it's also possible that + -- a single package provides an executable in two different ways, + -- though that's probably a bug if. Anyway it's a good lint to report + -- an error in all of these cases, even if some seem like they + -- shouldn't happen. + pkg <- case matchingElaboratedConfiguredPackages of + [] -> dieWithException verbosity $ UnknownExecutable exeName selectedUnitId + [elabPkg] -> do + info verbosity $ + "Selecting " + ++ prettyShow selectedUnitId + ++ " to supply " + ++ exeName + return elabPkg + elabPkgs -> + dieWithException verbosity $ + MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) + + let defaultExePath = + binDirectoryFor + (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) + + let dryRun = + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + let + -- HACK alert: when doing a per-package build (e.g. with a Custom setup), + -- 'elabExeDependencyPaths' will not contain any internal executables + -- (they are deliberately filtered out; and even if they weren't, they have the wrong paths). + -- We add them back in here to ensure that any "build-tool-depends" of + -- the current executable is available in PATH at runtime. + internalToolDepsOfThisExe + | ElabPackage{} <- elabPkgOrComp pkg + , let pkg_descr = elabPkgDescription pkg + , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr + , let thisExeBI = PD.buildInfo thisExe = + [ binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg depExeNm + | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI + , let depExeNm = unUnqualComponentName depExe + ] + | otherwise = + [] + extraPath = + elabExeDependencyPaths pkg + ++ ( fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx + ) + ++ internalToolDepsOfThisExe + + logExtraProgramSearchPath verbosity extraPath + progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) + + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else + runProgramInvocation + verbosity + emptyProgramInvocation + { progInvokePath = exePath + , progInvokeArgs = args + , progInvokeEnv = + ("PATH", Just $ progPath) + : dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan + } where (targetStr, args) = splitAt 1 targetAndArgs diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index dfa6ab71e19..9ffb9e6f3b2 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -63,6 +63,9 @@ import Distribution.Client.Types , PackageSpecifier (..) , UnresolvedSourcePackage ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) @@ -134,6 +137,7 @@ import Distribution.Verbosity ( normal ) +import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy.Char8 as BSL import System.Directory ( createDirectoryIfMissing @@ -146,6 +150,7 @@ import System.FilePath , (<.>) , () ) +import Text.PrettyPrint (text) ------------------------------------------------------------------------------- -- Command @@ -237,8 +242,14 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do let localPkgs = localPackages baseCtx targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings + either (reportTargetSelectorProblems verbosity . map constraintPackage) return + =<< readTargetSelectors + localPkgs + Nothing + ( map + (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) + targetStrings + ) -- elaborate path, create target directory mOutputPath' <- case mOutputPath of @@ -271,7 +282,12 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do | otherwise -> distSdistFile distDirLayout (packageId pkg) case reifyTargetSelectors localPkgs targetSelectors of - Left errs -> dieWithException verbosity $ SdistActionException . fmap renderTargetProblem $ errs + Left errs -> + dieWithException verbosity $ + SdistActionException $ + map + (prettyShow . fmap (text . renderTargetProblem)) + errs Right pkgs | length pkgs > 1 , not listSources @@ -370,7 +386,10 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do -- -reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] +reifyTargetSelectors + :: [PackageSpecifier UnresolvedSourcePackage] + -> [WithConstraintSource TargetSelector] + -> Either [WithConstraintSource TargetProblem] [UnresolvedSourcePackage] reifyTargetSelectors pkgs sels = case partitionEithers (foldMap go sels) of ([], sels') -> Right sels' @@ -391,14 +410,24 @@ reifyTargetSelectors pkgs sels = Just pkg -> Right pkg Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." - go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] - go (TargetPackage _ pids Nothing) = fmap getPkg pids - go (TargetAllPackages Nothing) = Right <$> pkgs' - go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] + go :: WithConstraintSource TargetSelector -> [Either (WithConstraintSource TargetProblem) UnresolvedSourcePackage] + go selector = + map + ( bimap + (\problem -> selector{constraintPackage = problem}) + id + ) + inner + where + inner = + case constraintPackage selector of + (TargetPackage _ pids Nothing) -> fmap getPkg pids + (TargetAllPackages Nothing) -> Right <$> pkgs' + (TargetPackage _ _ (Just kind)) -> [Left (AllComponentsOnly kind)] + (TargetAllPackages (Just kind)) -> [Left (AllComponentsOnly kind)] + (TargetPackageNamed pname _) -> [Left (NonlocalPackageNotAllowed pname)] + (TargetComponentUnknown pname _ _) -> [Left (NonlocalPackageNotAllowed pname)] + (TargetComponent _ cname _) -> [Left (ComponentsNotAllowed cname)] data TargetProblem = AllComponentsOnly ComponentKind diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs index 5f2e2cc4fcc..d25c59af41e 100644 --- a/cabal-install/src/Distribution/Client/Errors.hs +++ b/cabal-install/src/Distribution/Client/Errors.hs @@ -34,7 +34,6 @@ import Distribution.Package import Distribution.Pretty import Distribution.Simple (VersionRange) import Distribution.Simple.Utils -import Distribution.Solver.Types.ConstraintSource (ConstraintSource) import Network.URI import Text.Regex.Posix.ByteString (WrapError) @@ -161,7 +160,7 @@ data CabalInstallException | TargetSelectorNoTargetsInCwdFalse | TargetSelectorNoTargetsInProjectErr | TargetSelectorNoScriptErr String - | MatchingInternalErrorErr String String String [(String, [String])] ConstraintSource + | MatchingInternalErrorErr String String String [(String, [String])] | ReportPlanningFailure String | Can'tDownloadPackagesOffline [String] | SomePackagesFailedToInstall [(String, String)] @@ -760,7 +759,7 @@ exceptionMessageCabalInstall e = case e of ++ "' does not exist, " ++ "and only script targets may contain whitespace characters or end " ++ "with ':'" - MatchingInternalErrorErr t s sKind renderingsAndMatches constraintSource -> + MatchingInternalErrorErr t s sKind renderingsAndMatches -> "Internal error in target matching: could not make an " ++ "unambiguous fully qualified target selector for '" ++ t @@ -769,8 +768,6 @@ exceptionMessageCabalInstall e = case e of ++ s ++ "' (" ++ sKind - ++ " from " - ++ prettyShow constraintSource ++ ") that was expected to " ++ "be unambiguous but matches the following targets:\n" ++ unlines diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index ba8350b64b9..c45af55a0dc 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -196,11 +196,13 @@ import Control.Concurrent.MVar import Control.Exception ( bracket ) -import Data.Bifunctor (bimap) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Utils.Path ( unsafeMakeSymbolicPath ) @@ -292,13 +294,13 @@ withContextAndSelectors -- ^ A target filter -> NixStyleFlags a -- ^ Command line flags - -> [String] + -> [WithConstraintSource String] -- ^ Target strings or a script and args. -> GlobalFlags -- ^ Global flags. -> CurrentCommand -- ^ Current Command (usually for error reporting). - -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) + -> (TargetContext -> ProjectBaseContext -> [WithConstraintSource TargetSelector] -> IO b) -- ^ The body of your command action. -> IO b withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act = @@ -312,35 +314,37 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo (tc', ctx', sels) <- case targetStrings of -- Only script targets may end with ':'. -- Trying to readTargetSelectors such a target leads to a parse error. - [target] | ":" `isSuffixOf` target -> do - scriptOrError target [TargetSelectorNoScript $ TargetString1 target] + [target] | ":" `isSuffixOf` constraintPackage target -> do + scriptOrError + (constraintPackage target) + [ TargetSelectorNoScript . TargetString1 <$> target + ] _ -> do -- In the case where a selector is both a valid target and script, assume it is a target, -- because you can disambiguate the script with "./script" - eitherTargetSelectors <- readTargetSelectors (localPackages ctx) kind (map withUnknownConstraint targetStrings) + eitherTargetSelectors <- readTargetSelectors (localPackages ctx) kind targetStrings - -- TODO: Propagate `ConstraintSource` information here. - case bimap (map constraintPackage) (map constraintPackage) eitherTargetSelectors of + case eitherTargetSelectors of -- If there are no target selectors and no targets are fine, return -- the context - Left (TargetSelectorNoTargetsInCwd{} : _) + Left (WithConstraintSource{constraintPackage = TargetSelectorNoTargetsInCwd{}} : _) | [] <- targetStrings , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - Left err@(TargetSelectorNoTargetsInProject : _) + Left err@(WithConstraintSource{constraintPackage = TargetSelectorNoTargetsInProject} : _) -- If there are no target selectors and no targets are fine, return -- the context | [] <- targetStrings , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - | (script : _) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _ : _) + | (script : _) <- targetStrings -> scriptOrError (constraintPackage script) err + Left err@(WithConstraintSource{constraintPackage = TargetSelectorNoSuch t _} : _) | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _ : _) + Left err@(WithConstraintSource{constraintPackage = TargetSelectorExpected t _ _} : _) | TargetString1 script <- t -> scriptOrError script err - Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name. - | [script] <- targetStrings -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err + Left err@(WithConstraintSource{constraintPackage = MatchingInternalError _ _ _} : _) -- Handle ':' in middle of script name. + | [script] <- targetStrings -> scriptOrError (constraintPackage script) err + Left err -> reportTargetSelectorProblems verbosity (map constraintPackage err) Right sels -> return (tc, ctx, sels) act tc' ctx' sels @@ -349,7 +353,12 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo ignoreProject = flagIgnoreProject projectFlags cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing] + defaultTarget = + [ WithConstraintSource + { constraintPackage = TargetPackage TargetExplicitNamed [fakePackageId] Nothing + , constraintConstraint = ConstraintSourceImplicit + } + ] withProject = do ctx <- establishProjectBaseContext verbosity cliConfig cmd @@ -366,6 +375,10 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd + scriptOrError + :: FilePath + -> [WithConstraintSource TargetSelectorProblem] + -> IO (TargetContext, ProjectBaseContext, [WithConstraintSource TargetSelector]) scriptOrError script err = do exists <- doesFileExist script if exists @@ -405,7 +418,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) return (ScriptContext script executable', ctx', defaultTarget) - else reportTargetSelectorProblems verbosity err + else reportTargetSelectorProblems verbosity (map constraintPackage err) withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 99df992de13..b9dd938f5ed 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -168,7 +168,6 @@ import Text.EditDistance ( defaultEditCosts , restrictedDamerauLevenshteinDistance ) -import qualified Text.PrettyPrint as PP import qualified Prelude (foldr1) -- ------------------------------------------------------------ @@ -835,17 +834,11 @@ internalError msg = error $ "TargetSelector: internal error: " ++ msg -- | Throw an exception with a formatted message if there are any problems. -reportTargetSelectorProblems :: Verbosity -> [WithConstraintSource TargetSelectorProblem] -> IO a +reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a reportTargetSelectorProblems verbosity problems = do - case [ withConstraint{constraintPackage = str} - | withConstraint@WithConstraintSource - { constraintPackage = - TargetSelectorUnrecognised str - } <- - problems - ] of + case [str | TargetSelectorUnrecognised str <- problems] of [] -> return () - targets -> dieWithException verbosity $ ReportTargetSelectorProblems $ map (prettyShow . fmap PP.text) targets + targets -> dieWithException verbosity $ ReportTargetSelectorProblems targets case [ let renderedMatches = @@ -862,11 +855,7 @@ reportTargetSelectorProblems verbosity problems = do (showTargetSelector originalMatch) (showTargetSelectorKind originalMatch) renderedMatches - src - | WithConstraintSource - { constraintPackage = MatchingInternalError target originalMatch renderingsAndMatches - , constraintConstraint = src - } <- + | MatchingInternalError target originalMatch renderingsAndMatches <- problems ] of [] -> return () diff --git a/project-cabal/ghc-options.config b/project-cabal/ghc-options.config index 99794c17465..7ef2169ce49 100644 --- a/project-cabal/ghc-options.config +++ b/project-cabal/ghc-options.config @@ -1,6 +1,8 @@ program-options ghc-options: -fno-ignore-asserts + -fno-show-error-context + -fprint-typechecker-elaboration -- Warning: even though introduced with GHC 8.10, -Wunused-packages gives false -- positives with GHC 8.10.