packages feed

cabal-install 3.16.1.0 → 3.18.1.0

raw patch · 161 files changed

+9218/−5010 lines, 161 filesdep +hooks-exedep −lukkodep ~Cabaldep ~Cabal-syntaxdep ~QuickCheck

Dependencies added: hooks-exe

Dependencies removed: lukko

Dependency ranges changed: Cabal, Cabal-syntax, QuickCheck, base, base16-bytestring, cabal-install-solver, containers, directory, filepath, process, semaphore-compat, tasty, zlib

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # Change-log +## 3.18.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2026++* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.18.1.0.md+ ## 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025  * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.16.1.0.md
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2003-2025, Cabal Development Team.+Copyright (c) 2003-2026, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.
cabal-install.cabal view
@@ -1,7 +1,7 @@-Cabal-Version:      3.6+Cabal-Version:      3.8  Name:               cabal-install-Version:            3.16.1.0+Version:            3.18.1.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -13,7 +13,7 @@ License-File:       LICENSE Author:             Cabal Development Team (see AUTHORS file) Maintainer:         Cabal Development Team <cabal-devel@haskell.org>-Copyright:          2003-2025, Cabal Development Team+Copyright:          2003-2026, Cabal Development Team Category:           Distribution Build-type:         Simple Extra-Source-Files:@@ -34,16 +34,16 @@   default:      True   manual:       True -Flag lukko-  description:  Use @lukko@ for file-locking-  default:      False-  manual:       False- flag git-rev   description: include Git revision hash in version   default: False   manual: True +flag legacy-comparison+  description: Enable comparison between the new and legacy cabal.project parser+  default: False+  manual: True+ common warnings     ghc-options:       -Wall@@ -56,21 +56,24 @@     if impl(ghc < 8.8)       ghc-options: -Wnoncanonical-monadfail-instances +    if impl(ghc >= 9.14)+      ghc-options: -Wno-pattern-namespace-specifier -Wno-incomplete-record-selectors+ common base-dep     build-depends:-      , base >=4.13 && <4.22+      , base >=4.17 && <4.24  common cabal-dep     build-depends:-      , Cabal ^>=3.16.1.0+      , Cabal ^>=3.18  common cabal-syntax-dep     build-depends:-      , Cabal-syntax ^>=3.16.1.0+      , Cabal-syntax ^>=3.18  common cabal-install-solver-dep     build-depends:-      , cabal-install-solver ^>=3.16.1.0+      , cabal-install-solver ^>=3.18  library     import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep@@ -119,8 +122,6 @@         Distribution.Client.CmdTest         Distribution.Client.CmdUpdate         Distribution.Client.CmdGenBounds-        Distribution.Client.Compat.Directory-        Distribution.Client.Compat.ExecutablePath         Distribution.Client.Compat.Orphans         Distribution.Client.Compat.Prelude         Distribution.Client.Compat.Semaphore@@ -131,6 +132,7 @@         Distribution.Client.Dependency.Types         Distribution.Client.DistDirLayout         Distribution.Client.Errors+        Distribution.Client.Errors.Parser         Distribution.Client.Fetch         Distribution.Client.FetchUtils         Distribution.Client.FileMonitor@@ -160,6 +162,7 @@         Distribution.Client.Init.Simple         Distribution.Client.Init.Types         Distribution.Client.Init.Utils+        Distribution.Client.InLibrary         Distribution.Client.Install         Distribution.Client.InstallPlan         Distribution.Client.InstallSymlink@@ -168,7 +171,6 @@         Distribution.Client.Main         Distribution.Client.Manpage         Distribution.Client.ManpageFlags-        Distribution.Client.Nix         Distribution.Client.NixStyleOptions         Distribution.Client.PackageHash         Distribution.Client.ParseUtils@@ -177,7 +179,11 @@         Distribution.Client.ProjectBuilding.PackageFileMonitor         Distribution.Client.ProjectBuilding.Types         Distribution.Client.ProjectConfig+        Distribution.Client.ProjectConfig.FieldGrammar+        Distribution.Client.ProjectConfig.Import         Distribution.Client.ProjectConfig.Legacy+        Distribution.Client.ProjectConfig.Lens+        Distribution.Client.ProjectConfig.Parsec         Distribution.Client.ProjectConfig.Types         Distribution.Client.ProjectFlags         Distribution.Client.ProjectOrchestration@@ -225,6 +231,7 @@         Distribution.Client.Upload         Distribution.Client.Utils         Distribution.Client.Utils.Json+        Distribution.Client.Utils.Newtypes         Distribution.Client.Utils.Parsec         Distribution.Client.VCS         Distribution.Client.Version@@ -233,7 +240,7 @@     build-depends:       , async      >= 2.0      && < 2.3       , array      >= 0.4      && < 0.6-      , base16-bytestring >= 0.1.1 && < 1.1+      , base16-bytestring >= 1.0 && < 1.1       , binary     >= 0.7.3    && < 0.9       , bytestring >= 0.10.6.0 && < 0.13       , containers >= 0.5.6.2  && < 0.9@@ -243,24 +250,25 @@       , edit-distance >= 0.2.2 && < 0.3       , exceptions >= 0.10.4   && < 0.11       , filepath   >= 1.4.0.0  && < 1.6-      , HTTP       >= 4000.1.5 && < 4000.5+      , hooks-exe  >= 3.18     && < 3.19+      , HTTP       >= 4000.1.5 && < 4000.6       , mtl        >= 2.0      && < 2.4       , network-uri >= 2.6.2.0 && < 2.7       , pretty     >= 1.1      && < 1.2-      , process    >= 1.2.3.0  && < 1.7+      , process    >= 1.2.3.0  && < 1.6.24 || == 1.6.26.0 || >= 1.6.26.2 && < 1.7       , random     >= 1.2      && < 1.4       , stm        >= 2.0      && < 2.6       , tar        >= 0.5.0.3  && < 0.8-      , time       >= 1.5.0.1  && < 1.16-      , zlib       >= 0.5.3    && < 0.8+      , time       >= 1.5.0.1  && < 1.17+      , zlib       >= 0.6      && < 0.8       , hackage-security >= 0.6.2.0 && < 0.7       , text       >= 1.2.3    && < 1.3 || >= 2.0 && < 2.2       , parsec     >= 3.1.13.0 && < 3.2-      , open-browser >= 0.2.1.0 && < 0.5+      , open-browser >= 0.2.1.0 && < 0.6       , regex-base  >= 0.94.0.0 && <0.95       , regex-posix >= 0.96.0.0 && <0.97       , safe-exceptions >= 0.1.7.0 && < 0.2-      , semaphore-compat >= 1.0.0 && < 1.1+      , semaphore-compat >= 2.0.1 && < 2.1      if flag(native-dns)       if os(windows)@@ -277,19 +285,22 @@       build-depends:         , unix >= 2.5 && < 2.8 || >= 2.8.6.0 && < 2.9 -    if flag(lukko)-      build-depends:-        , lukko >= 0.1 && <0.2-     -- pull in process version with fixed waitForProcess error     if impl(ghc >=8.2)       build-depends:         , process >= 1.6.15.0 +    if os(darwin)+      build-depends:+        , process >= 1.6.29.0+     if flag(git-rev)       build-depends: githash ^>= 0.1.7.0       cpp-options: -DGIT_REV +    if flag(legacy-comparison)+      cpp-options: -DLEGACY_COMPARISON+ executable cabal     import: warnings, base-dep     main-is: Main.hs@@ -328,6 +339,7 @@       UnitTests.Distribution.Client.Glob       UnitTests.Distribution.Client.GZipUtils       UnitTests.Distribution.Client.IndexUtils+      UnitTests.Distribution.Client.IndexUtils.ActiveRepos       UnitTests.Distribution.Client.IndexUtils.Timestamp       UnitTests.Distribution.Client.Init       UnitTests.Distribution.Client.Init.Golden@@ -376,8 +388,28 @@       , tasty-expected-failure       , tasty-hunit >= 0.10       , tree-diff-      , QuickCheck >= 2.14.3 && <2.18+      , QuickCheck >= 2.14.3 && <2.19 +-- Tests for the project file parser+test-suite parser-tests+    import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep+    default-language: Haskell2010+    ghc-options: -rtsopts -threaded++    type: exitcode-stdio-1.0+    main-is: Tests.hs+    hs-source-dirs: parser-tests+    build-depends:+      , cabal-install+      , containers+      , directory+      , filepath+      , network-uri >= 2.6.2.0 && <2.7+      , tasty >= 1.2.3 && <1.6+      , tasty-hunit >= 0.10+    other-modules:+      Tests.ParserTests+ -- Tests to run with a limited stack and heap size -- The test suite name must be keep short cause a longer one -- could make the build generating paths which exceeds the windows@@ -414,9 +446,6 @@   hs-source-dirs: tests   default-language: Haskell2010 -  other-modules:-    IntegrationTests2.CPP-   build-depends:     , bytestring     , cabal-install@@ -424,7 +453,7 @@     , directory     , filepath     , process-    , tasty >= 1.5 && <1.6+    , tasty >= 1.5.4 && <1.6     , tasty-hunit >= 0.10     , tasty-expected-failure     , silently@@ -465,5 +494,5 @@     , tasty-expected-failure     , tasty-hunit >= 0.10     , tasty-quickcheck <0.12-    , QuickCheck >= 2.14 && <2.18+    , QuickCheck >= 2.14 && <2.19     , pretty-show >= 1.6.15
+ parser-tests/Tests.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.Tasty (defaultMain)+import Tests.ParserTests (parserTests)++main :: IO ()+main = defaultMain parserTests
+ parser-tests/Tests/ParserTests.hs view
@@ -0,0 +1,623 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Tests for the project file parser+module Tests.ParserTests (parserTests) where++import Control.Monad.IO.Class+  ( MonadIO (liftIO)+  )+import Data.Either (fromRight)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import qualified Data.Set as Set+import Distribution.Client.BuildReports.Types (ReportLevel (..))+import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (..))+import Distribution.Client.Dependency.Types (PreSolver (..))+import Distribution.Client.DistDirLayout+import Distribution.Client.HttpUtils+import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))+import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), headTotalIndexState, insertIndexState)+import Distribution.Client.ProjectConfig+import Distribution.Client.RebuildMonad (runRebuild)+import Distribution.Client.Targets (readUserConstraint)+import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDepMod (..), RelaxDepScope (..), RelaxDepSubject (..), RelaxDeps (..), RelaxedDep (..))+import Distribution.Client.Types.InstallMethod (InstallMethod (..))+import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))+import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..), asPosixPath)+import Distribution.Client.Types.RepoName (RepoName (..))+import Distribution.Client.Types.SourceRepo+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..))+import Distribution.Compat.Prelude+import Distribution.Compiler (CompilerFlavor (..))+import Distribution.Parsec (simpleParsec)+import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDBX (..), ProfDetailLevel (..))+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs (InstallDirs (..), toPathTemplate)+import Distribution.Simple.Setup (DumpBuildInfo (..), HaddockTarget (..), TestShowDetails (..))+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))+import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..))+import Distribution.Solver.Types.Settings+  ( AllowBootLibInstalls (..)+  , CountConflicts (..)+  , FineGrainedConflicts (..)+  , IndependentGoals (..)+  , MinimizeConflictSet (..)+  , OnlyConstrained (..)+  , PreferOldest (..)+  , ReorderGoals (..)+  , StrongFlags (..)+  )+import Distribution.System (OS (..), buildOS)+import Distribution.Types.CondTree (CondTree (..))+import Distribution.Types.Flag (mkFlagAssignment)+import Distribution.Types.PackageId (PackageIdentifier (..))+import Distribution.Types.PackageName+import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))+import Distribution.Types.SourceRepo (KnownRepoType (..), RepoType (..))+import Distribution.Types.Version (mkVersion)+import Distribution.Types.VersionRange.Internal (VersionRange (..))+import Distribution.Utils.NubList+import Distribution.Verbosity+import Network.URI (parseURI)+import System.Directory (canonicalizePath, doesFileExist)+import System.FilePath ((</>))+import Prelude ()++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)++parserTests :: TestTree+parserTests =+  testGroup+    "project files parsec tests"+    [ testCase "read packages" testPackages+    , testCase "read optional-packages" testOptionalPackages+    , testCase "read extra-packages" testExtraPackages+    , testCase "read source-repository-package" testSourceRepoList+    , testCase "read project-config-build-only" testProjectConfigBuildOnly+    , testCase "read project-config-shared" testProjectConfigShared+    , testCase "read install-dirs" testInstallDirs+    , testCase "read remote-repos" testRemoteRepos+    , testCase "read local-no-index-repos" testLocalNoIndexRepos+    , testCase "set explicit provenance" testProjectConfigProvenance+    , testCase "read project-config-local-packages" testProjectConfigLocalPackages+    , testCase "read project-config-all-packages" testProjectConfigAllPackages+    , testCase "read project-config-specific-packages" testProjectConfigSpecificPackages+    , testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat+    , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat+    , testCase "test program-locations concatenation" testProgramLocationsConcat+    , testCase "test program-options concatenation" testProgramOptionsConcat+    , testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat+    , testCase "test library-coverage overwrites coverage" testLibraryCoverage+    , testCase "test haddock-all flag" testHaddockAll+    , testCase "test override haddock-all: True" testHaddockAllOverwriteTrue+    , testCase "test override haddock-all: False" testHaddockAllOverwriteFalse+    ]++testPackages :: Assertion+testPackages = do+  let expected = [".", "packages/packages.cabal"]+  (config, legacy) <- readConfigDefault "packages"+  assertConfigEquals expected config legacy (projectPackages . snd . condTreeData)++testOptionalPackages :: Assertion+testOptionalPackages = do+  let expected = [".", "packages/packages.cabal"]+  (config, legacy) <- readConfigDefault "optional-packages"+  assertConfigEquals expected config legacy (projectPackagesOptional . snd . condTreeData)++testSourceRepoList :: Assertion+testSourceRepoList = do+  (config, legacy) <- readConfigDefault "source-repository-packages"+  assertConfigEquals expected config legacy (projectPackagesRepo . snd . condTreeData)+  where+    expected =+      [ SourceRepositoryPackage+          { srpType = KnownRepoType Git+          , srpLocation = "https://example.com/Project.git"+          , srpTag = Just "1234"+          , srpBranch = Nothing+          , srpSubdir = []+          , srpCommand = []+          }+      , SourceRepositoryPackage+          { srpType = KnownRepoType Git+          , srpLocation = "https://example.com/example-dir/"+          , srpTag = Just "12345"+          , srpBranch = Nothing+          , srpSubdir = ["subproject"]+          , srpCommand = []+          }+      ]++testExtraPackages :: Assertion+testExtraPackages = do+  (config, legacy) <- readConfigDefault "extra-packages"+  assertConfigEquals expected config legacy (projectPackagesNamed . snd . condTreeData)+  where+    expected =+      [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0]))+      , PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9])))+      ]++testProjectConfigBuildOnly :: Assertion+testProjectConfigBuildOnly = do+  (config, legacy) <- readConfigDefault "project-config-build-only"+  assertConfigEquals expected config legacy (projectConfigBuildOnly . snd . condTreeData)+  where+    expected = ProjectConfigBuildOnly{..}+    projectConfigVerbosity = toFlag (mkVerbosityFlags Verbose)+    projectConfigDryRun = mempty -- cli only+    projectConfigOnlyDeps = mempty -- cli only+    projectConfigOnlyDownload = mempty -- cli only+    projectConfigSummaryFile = toNubList [toPathTemplate "summaryFile", toPathTemplate "summaryFile2"]+    projectConfigLogFile = toFlag $ toPathTemplate "myLog.log"+    projectConfigBuildReports = toFlag DetailedReports+    projectConfigReportPlanningFailure = toFlag True+    projectConfigSymlinkBinDir = toFlag "some-bindir"+    projectConfigNumJobs = toFlag $ Just 4+    projectConfigUseSemaphore = toFlag True+    projectConfigKeepGoing = toFlag True+    projectConfigOfflineMode = toFlag True+    projectConfigKeepTempFiles = toFlag True+    projectConfigHttpTransport = toFlag "wget"+    projectConfigIgnoreExpiry = toFlag True+    projectConfigCacheDir = toFlag "some-cache-dir"+    projectConfigLogsDir = toFlag "logs-directory"+    projectConfigClientInstallFlags =+      ClientInstallFlags+        { cinstInstallLibs = Flag True+        , cinstEnvironmentPath = Flag "path/to/env"+        , cinstOverwritePolicy = Flag AlwaysOverwrite+        , cinstInstallMethod = Flag InstallMethodSymlink+        , cinstInstalldir = Flag "path/to/installdir"+        }++testProjectConfigShared :: Assertion+testProjectConfigShared = do+  (config, legacy) <- readConfigDefault "project-config-shared"+  assertConfigEquals expected config legacy (projectConfigShared . snd . condTreeData)+  where+    expected = ProjectConfigShared{..}+    projectConfigDistDir = toFlag "something"+    projectConfigConfigFile = mempty -- cli only+    projectConfigProjectFileParser = mempty -- cli only+    projectConfigProjectDir = toFlag "my-project-dir"+    projectConfigProjectFile = toFlag "my-project"+    projectConfigIgnoreProject = toFlag False+    projectConfigHcFlavor = toFlag GHCJS+    projectConfigHcPath = toFlag "/some/path/to/compiler"+    projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg"+    projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index"+    projectConfigInstallDirs = mempty -- tested below in testInstallDirs+    projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")]+    projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos+    projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos+    projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride])+    projectConfigIndexState =+      let+        hackageState = IndexStateTime $ fromJust $ simpleParsec "2020-05-06T22:33:27Z"+        indexState' = insertIndexState (RepoName "hackage.haskell.org") hackageState headTotalIndexState+        headHackageState = IndexStateTime $ fromJust $ simpleParsec "2020-04-29T04:11:05Z"+        indexState'' = insertIndexState (RepoName "head.hackage") headHackageState indexState'+       in+        toFlag indexState''+    projectConfigStoreDir = toFlag "a/store/dir/path" -- cli only+    projectConfigConstraints =+      let+        bar = fromRight (error "error parsing bar") $ readUserConstraint "bar == 2.1"+        barFlags = fromRight (error "error parsing bar flags") $ readUserConstraint "bar +foo -baz"+        source = ConstraintSourceProjectConfig $ ProjectConfigPath $ "cabal.project" :| []+       in+        [(bar, source), (barFlags, source)]+    projectConfigPreferences = [PackageVersionConstraint (mkPackageName "foo") (ThisVersion (mkVersion [0, 9])), PackageVersionConstraint (mkPackageName "baz") (LaterVersion (mkVersion [2, 0]))]+    projectConfigCabalVersion = Flag (mkVersion [1, 24, 0, 1])+    projectConfigSolver = Flag AlwaysModular+    projectConfigAllowOlder = Just (AllowOlder $ RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep")), RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "pkga") (mkVersion [1, 1, 2]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep-pkg"))])+    projectConfigAllowNewer = Just (AllowNewer $ RelaxDepsSome [RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "pkgb") (mkVersion [1, 2, 3]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep-pkgb")), RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "importantlib"))])+    projectConfigWriteGhcEnvironmentFilesPolicy = Flag AlwaysWriteGhcEnvironmentFiles+    projectConfigMaxBackjumps = toFlag 42+    projectConfigReorderGoals = Flag (ReorderGoals True)+    projectConfigCountConflicts = Flag (CountConflicts False)+    projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts False)+    projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet True)+    projectConfigStrongFlags = Flag (StrongFlags True)+    projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls True)+    projectConfigOnlyConstrained = Flag OnlyConstrainedAll+    projectConfigPerComponent = Flag True+    projectConfigIndependentGoals = Flag (IndependentGoals True)+    projectConfigPreferOldest = Flag (PreferOldest True)+    projectConfigProgPathExtra = toNubList ["/foo/bar", "/baz/quux"]+    projectConfigMultiRepl = toFlag True++testInstallDirs :: Assertion+testInstallDirs = do+  (config, legacy) <- readConfigDefault "install-dirs"+  assertConfigEquals expected config legacy (projectConfigInstallDirs . projectConfigShared . snd . condTreeData)+  where+    expected =+      InstallDirs+        { prefix = Flag $ toPathTemplate "my/prefix-path"+        , bindir = Flag $ toPathTemplate "bin/dir/"+        , libdir = Flag $ toPathTemplate "lib/dir/path"+        , libsubdir = Flag $ toPathTemplate "/lib/sub/dir"+        , dynlibdir = Flag $ toPathTemplate "dyn/lib/dir/path"+        , bytecodelibdir = Flag $ toPathTemplate "bytecode/lib/dir/path"+        , flibdir = mempty+        , libexecdir = Flag $ toPathTemplate "lib/exec/dir/"+        , libexecsubdir = Flag $ toPathTemplate "libexec/subdir"+        , includedir = mempty+        , datadir = Flag $ toPathTemplate "path/to/datadir/"+        , datasubdir = Flag $ toPathTemplate "a/datadir/subdir"+        , docdir = Flag $ toPathTemplate "path/to/docs"+        , mandir = mempty+        , htmldir = Flag $ toPathTemplate "dir/html/"+        , haddockdir = Flag $ toPathTemplate "haddock/dir"+        , sysconfdir = Flag $ toPathTemplate "sys/conf/dir"+        }++testRemoteRepos :: Assertion+testRemoteRepos = do+  (config, legacy) <- readConfigDefault "remote-repos"+  let actualRemoteRepos = (fromNubList . projectConfigRemoteRepos . projectConfigShared . snd . condTreeData) config+  assertBool "Expected RemoteRepos do not match parsed values" $ compareLists expected actualRemoteRepos compareRemoteRepos+  assertConfigEquals mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData)+  where+    expected = [packagesRepository, morePackagesRepository, secureLocalRepository]+    packagesRepository =+      RemoteRepo+        { remoteRepoName = RepoName "packages.example.org"+        , remoteRepoURI = fromJust $ parseURI "http://packages.example.org/"+        , remoteRepoSecure = pure True+        , remoteRepoRootKeys = ["21", "42"]+        , remoteRepoKeyThreshold = 2+        , remoteRepoShouldTryHttps = False+        }+    morePackagesRepository =+      RemoteRepo+        { remoteRepoName = RepoName "more-packages.example.org"+        , remoteRepoURI = fromJust $ parseURI "https://more-packages.example.org/"+        , remoteRepoSecure = pure True+        , remoteRepoRootKeys = ["foo", "bar"]+        , remoteRepoKeyThreshold = 1+        , remoteRepoShouldTryHttps = False+        }+    secureLocalRepository =+      RemoteRepo+        { remoteRepoName = RepoName "my-secure-local-repository"+        , remoteRepoURI = fromJust $ parseURI "file:/path/to/secure/repo"+        , remoteRepoSecure = pure True+        , remoteRepoRootKeys = ["123"]+        , remoteRepoKeyThreshold = 1+        , remoteRepoShouldTryHttps = False+        }++testLocalNoIndexRepos :: Assertion+testLocalNoIndexRepos = do+  (config, legacy) <- readConfigDefault "local-no-index-repos"+  let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData) config+  assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected actualLocalRepos compareLocalRepos+  assertConfigEquals mempty config legacy (projectConfigRemoteRepos . projectConfigShared . snd . condTreeData)+  where+    expected = [myRepository, mySecureRepository]+    myRepository =+      LocalRepo+        { localRepoName = RepoName "my-repository"+        , localRepoPath = normalisePath "/absolute/path/to/directory"+        , localRepoSharedCache = False+        }+    mySecureRepository =+      LocalRepo+        { localRepoName = RepoName "my-other-repository"+        , localRepoPath = normalisePath "/another/path/to/repository"+        , localRepoSharedCache = False+        }+    normalisePath path = case buildOS of+      Windows -> asPosixPath path+      _ -> path++testProjectConfigProvenance :: Assertion+testProjectConfigProvenance = do+  let expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| []))+  (config, legacy) <- readConfigDefault "empty"+  assertConfigEquals expected config legacy (projectConfigProvenance . snd . condTreeData)++testProjectConfigLocalPackages :: Assertion+testProjectConfigLocalPackages = do+  (config, legacy) <- readConfigDefault "project-config-local-packages"+  assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)+  where+    expected = PackageConfig{..}+    packageConfigProgramPaths = MapLast $ Map.fromList [("ghc", "/tmp/bin/ghc"), ("gcc", "/tmp/bin/gcc")]+    packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-foo"]), ("gcc", ["-baz", "-quux"])]+    packageConfigProgramPathExtra = toNubList ["/tmp/bin/extra", "/usr/local/bin"]+    packageConfigFlagAssignment = mkFlagAssignment [("foo", True), ("bar", False)]+    packageConfigVanillaLib = Flag False+    packageConfigSharedLib = Flag True+    packageConfigStaticLib = Flag True+    packageConfigDynExe = Flag True+    packageConfigFullyStaticExe = Flag True+    packageConfigProf = Flag True+    packageConfigProfLib = Flag True+    packageConfigProfShared = Flag False+    packageConfigProfExe = Flag True+    packageConfigProfDetail = Flag ProfDetailAllFunctions+    packageConfigProfLibDetail = Flag ProfDetailExportedFunctions+    packageConfigConfigureArgs = ["-some-arg", "/some/path"]+    packageConfigOptimization = Flag MaximumOptimisation+    packageConfigProgPrefix = Flag $ toPathTemplate "another/path"+    packageConfigProgSuffix = Flag $ toPathTemplate "and/another/path"+    packageConfigExtraLibDirs = ["so", "many", "lib/dirs"]+    packageConfigExtraLibDirsStatic = ["a/few", "static/lib/dirs"]+    packageConfigExtraFrameworkDirs = ["osx/framework", "dirs"]+    packageConfigExtraIncludeDirs = ["incredible/amount", "of", "include", "directories"]+    packageConfigGHCiLib = Flag False+    packageConfigBytecodeLib = Flag False+    packageConfigSplitSections = Flag True+    packageConfigSplitObjs = Flag True+    packageConfigStripExes = Flag False+    packageConfigStripLibs = Flag False+    packageConfigTests = Flag True+    packageConfigBenchmarks = Flag True+    packageConfigCoverage = Flag True+    packageConfigRelocatable = Flag True+    packageConfigDebugInfo = Flag MaximalDebugInfo+    packageConfigDumpBuildInfo = Flag DumpBuildInfo+    packageConfigRunTests = Flag True+    packageConfigDocumentation = Flag True+    -- Haddock options+    packageConfigHaddockHoogle = Flag True+    packageConfigHaddockHtml = Flag False+    packageConfigHaddockHtmlLocation = Flag "http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html"+    packageConfigHaddockForeignLibs = Flag True+    packageConfigHaddockExecutables = Flag True+    packageConfigHaddockTestSuites = Flag True+    packageConfigHaddockBenchmarks = Flag True+    packageConfigHaddockInternal = Flag True+    packageConfigHaddockCss = Flag "some/path/to/file.css"+    packageConfigHaddockLinkedSource = Flag True+    packageConfigHaddockQuickJump = Flag True+    packageConfigHaddockHscolourCss = Flag "another/path/to/hscolour.css"+    packageConfigHaddockContents = Flag $ toPathTemplate "https://example.com/$pkg/contents"+    packageConfigHaddockIndex = Flag $ toPathTemplate "separately-generated/HTML/index"+    packageConfigHaddockBaseUrl = Flag "https://example.com/haddock-base-url"+    packageConfigHaddockResourcesDir = Flag "/haddock/static"+    packageConfigHaddockOutputDir = Flag "/haddock/output"+    packageConfigHaddockUseUnicode = Flag False+    packageConfigHaddockForHackage = Flag ForHackage+    packageConfigTestHumanLog = Flag $ toPathTemplate "human-log.log"+    packageConfigTestMachineLog = Flag $ toPathTemplate "machine.log"+    packageConfigTestShowDetails = Flag Streaming+    packageConfigTestKeepTix = Flag True+    packageConfigTestWrapper = Flag "/test-wrapper-path/"+    packageConfigTestFailWhenNoTestSuites = Flag True+    packageConfigTestTestOptions = [toPathTemplate "--some-option", toPathTemplate "42"]+    packageConfigBenchmarkOptions = [toPathTemplate "--some-benchmark-option", toPathTemplate "--another-option"]++testProjectConfigAllPackages :: Assertion+testProjectConfigAllPackages = do+  (config, legacy) <- readConfigDefault "project-config-all-packages"+  assertConfigEquals expected config legacy (projectConfigAllPackages . snd . condTreeData)+  where+    expected :: PackageConfig+    expected =+      mempty+        { packageConfigProfDetail = Flag ProfDetailAllFunctions+        , packageConfigProfLibDetail = Flag ProfDetailExportedFunctions+        }++testProjectConfigSpecificPackages :: Assertion+testProjectConfigSpecificPackages = do+  (config, legacy) <- readConfigDefault "project-config-specific-packages"+  assertConfigEquals expected config legacy (projectConfigSpecificPackage . snd . condTreeData)+  where+    expected = MapMappend $ Map.fromList [("foo", expectedFoo), ("bar", expectedBar), ("baz", expectedBaz)]+    expectedFoo :: PackageConfig+    expectedFoo =+      mempty+        { packageConfigProfDetail = Flag ProfDetailAllFunctions+        , packageConfigProfLibDetail = Flag ProfDetailExportedFunctions+        , packageConfigVanillaLib = Flag True+        }+    expectedBar :: PackageConfig+    expectedBar =+      mempty+        { packageConfigProfDetail = Flag ProfDetailTopLate+        , packageConfigProfLibDetail = Flag ProfDetailNone+        , packageConfigProgPrefix = Flag $ toPathTemplate "prefix/path"+        }+    expectedBaz :: PackageConfig+    expectedBaz =+      mempty+        { packageConfigSharedLib = Flag True+        }++testAllPackagesConcat :: Assertion+testAllPackagesConcat = do+  (config, legacy) <- readConfigDefault "all-packages-concat"+  assertConfigEquals expected config legacy (projectConfigAllPackages . snd . condTreeData)+  where+    expected :: PackageConfig+    expected =+      mempty+        { packageConfigSharedLib = Flag True+        , packageConfigStaticLib = Flag True+        , packageConfigProgramArgs =+            MapMappend $+              Map.fromList+                [ ("ghc", ["-fwarn-tabs", "-optc-fno-builtin-malloc", "-Wall", "-optc-fno-builtin-realloc", "-fwrite-ide-info"])+                ]+        }++testSpecificPackagesConcat :: Assertion+testSpecificPackagesConcat = do+  (config, legacy) <- readConfigDefault "specific-packages-concat"+  assertConfigEquals expected config legacy (projectConfigSpecificPackage . snd . condTreeData)+  where+    expected = MapMappend $ Map.fromList [("foo", expectedFoo)]+    expectedFoo :: PackageConfig+    expectedFoo =+      mempty+        { packageConfigSharedLib = Flag True+        , packageConfigStaticLib = Flag True+        , packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-threaded"])]+        }++testProgramLocationsConcat :: Assertion+testProgramLocationsConcat = do+  (config, legacy) <- readConfigDefault "program-locations-concat"+  assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)+  where+    expected :: PackageConfig+    expected =+      mempty+        { packageConfigProgramPaths = MapLast $ Map.fromList [("gcc", "/tmp/bin/gcc"), ("ghc", "/tmp/bin/ghc")]+        }++testProgramOptionsConcat :: Assertion+testProgramOptionsConcat = do+  (config, legacy) <- readConfigDefault "program-options-concat"+  assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)+  where+    expected :: PackageConfig+    expected =+      mempty+        { packageConfigProgramArgs =+            MapMappend $+              Map.fromList+                [ ("ghc", ["-threaded", "-Wall", "-fno-state-hack"])+                , ("gcc", ["-baz", "-foo", "-bar"])+                , ("haddock", ["--optghc=-optP -P"])+                , ("ld", ["-Wl,--gc-sections"])+                ]+        }++testRelaxDepsConcat :: Assertion+testRelaxDepsConcat = do+  (config, legacy) <- readConfigDefault "relax-deps-concat"+  assertConfigEquals expectedAllowNewer config legacy (projectConfigAllowNewer . projectConfigShared . snd . condTreeData)+  assertConfigEquals expectedAllowOlder config legacy (projectConfigAllowOlder . projectConfigShared . snd . condTreeData)+  where+    expectedAllowNewer :: Maybe AllowNewer+    expectedAllowNewer =+      pure $+        AllowNewer $+          RelaxDepsSome+            [ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "cassava") (mkVersion [0, 5, 2, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "template-haskell"))+            ]+    expectedAllowOlder :: Maybe AllowOlder+    expectedAllowOlder =+      pure $+        AllowOlder $+          RelaxDepsSome+            [ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "mtl") (mkVersion [2, 3, 1]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "aeson") (mkVersion [2, 2, 3, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "bytestring"))+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "containers") (mkVersion [0, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "array"))+            ]++-- | Tests that if both library-coverage and coverage flags are specified, library-coverage is used.+testLibraryCoverage :: Assertion+testLibraryCoverage = do+  (config, legacy) <- readConfigDefault "library-coverage"+  assertConfigEquals (Flag False) config legacy (packageConfigCoverage . projectConfigLocalPackages . snd . condTreeData)++testHaddockAll :: Assertion+testHaddockAll = do+  (config, legacy) <- readConfigDefault "haddock-all"+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)++-- | Tests that an explicitly set field can override a value inherited from haddock-all.+testHaddockAllOverwriteTrue :: Assertion+testHaddockAllOverwriteTrue = do+  (config, legacy) <- readConfigDefault "haddock-all-overwrite-true"+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)++testHaddockAllOverwriteFalse :: Assertion+testHaddockAllOverwriteFalse = do+  (config, legacy) <- readConfigDefault "haddock-all-overwrite-false"+  assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag False) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag False) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)+  assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)++-------------------------------------------------------------------------------+-- Test Utilities+-------------------------------------------------------------------------------+baseDir :: FilePath+baseDir = "parser-tests" </> "Tests" </> "files"++verbosity :: Verbosity+verbosity = mkVerbosity defaultVerbosityHandles normal++readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)+readConfigDefault testSubDir = readConfig testSubDir "cabal.project"++readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)+readConfig testSubDir projectFileName = do+  (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName+  exists <- liftIO $ doesFileExist projectConfigFp+  assertBool ("projectConfig does not exist: " <> projectConfigFp) exists+  httpTransport <- liftIO $ configureTransport verbosity [] Nothing+  parsec <-+    liftIO $+      runRebuild testRootFp $+        readProjectFileSkeletonParsec verbosity httpTransport distDirLayout ProjectFileKeyMain+  legacy <-+    liftIO $+      runRebuild testRootFp $+        readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout ProjectFileKeyMain+  return (parsec, legacy)++assertConfigEquals :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> Assertion+assertConfigEquals expected config configLegacy access = do+  assertEqual "Expectation does not match result of Legacy parser" expected actualLegacy+  assertEqual "Parsed Config does not match expected" expected actual+  where+    actual = access config+    actualLegacy = access configLegacy++-- | Represents the directory structure and associated file paths for a test+data TestDir = TestDir+  { _testDirTestRootFp :: FilePath+  -- ^ Every test has a root directory in ./files/<test-title>+  , _testDirProjectConfigFp :: FilePath+  -- ^ Every test has a project config in testDirTestRootFp/cabal.project+  , _testDirDistDirLayout :: DistDirLayout+  }++testDirInfo :: FilePath -> FilePath -> IO TestDir+testDirInfo testSubDir projectFileName = do+  projectRootDir <- canonicalizePath (baseDir </> testSubDir)+  let+    projectRoot = ProjectRootExplicit projectRootDir projectFileName+    distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing+    projectConfigFp = distProjectFile distDirLayout ProjectFileKeyMain+  return $ TestDir projectRootDir projectConfigFp distDirLayout++-- | Compares two lists element-wise using a comparison function.+compareLists :: [a] -> [a] -> (a -> a -> Bool) -> Bool+compareLists xs ys compare' = length xs == length ys && all (uncurry compare') (zip xs ys)++-- | Compares LocalRepos ignoring field 'localRepoSharedCache' because we do not parse it.+compareLocalRepos :: LocalRepo -> LocalRepo -> Bool+compareLocalRepos repo1 repo2 =+  localRepoName repo1 == localRepoName repo2+    && localRepoPath repo1 == localRepoPath repo2++-- | Compares RemoteRepos ignoring field 'remoteRepoShouldTryHttps' because we do not parse it.+compareRemoteRepos :: RemoteRepo -> RemoteRepo -> Bool+compareRemoteRepos repo1 repo2 =+  remoteRepoName repo1 == remoteRepoName repo2+    && remoteRepoURI repo1 == remoteRepoURI repo2+    && remoteRepoSecure repo1 == remoteRepoSecure repo2+    && remoteRepoRootKeys repo1 == remoteRepoRootKeys repo2+    && remoteRepoKeyThreshold repo1 == remoteRepoKeyThreshold repo2
src/Distribution/Client/BuildReports/Anonymous.hs view
@@ -31,6 +31,7 @@   --    showList,   ) where +import Data.Either (rights) import Distribution.Client.Compat.Prelude import Prelude () @@ -89,7 +90,7 @@       Left (BR.BuildFailed _) -> BuildFailed       Left (BR.TestsFailed _) -> TestsFailed       Left (BR.InstallFailed _) -> InstallFailed-      Right (BR.BuildResult _ _ _) -> InstallOk+      Right BR.BuildResult{} -> InstallOk     convertDocsOutcome = case result of       Left _ -> NotTried       Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried@@ -110,8 +111,7 @@ -------------------------------------------------------------------------------  fieldDescrs-  :: ( Applicative (g BuildReport)-     , FieldGrammar c g+  :: ( FieldGrammar c g      , c (Identity Arch)      , c (Identity CompilerId)      , c (Identity FlagAssignment)@@ -140,10 +140,10 @@  parseBuildReport :: BS.ByteString -> Either String BuildReport parseBuildReport s = case snd $ runParseResult $ parseFields s of-  Left (_, perrors) -> Left $ unlines [err | PError _ err <- toList perrors]+  Left (_, perrors) -> Left $ unlines [err | PErrorWithSource _ (PError _ err) <- toList perrors]   Right report -> Right report -parseFields :: BS.ByteString -> ParseResult BuildReport+parseFields :: BS.ByteString -> ParseResult src BuildReport parseFields input = do   fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input   case partitionFields fields of@@ -152,7 +152,7 @@  parseBuildReportList :: BS.ByteString -> [BuildReport] parseBuildReportList str =-  [report | Right report <- map parseBuildReport (split str)]+  rights (map parseBuildReport $ split str)   where     split :: BS.ByteString -> [BS.ByteString]     split = filter (not . BS.null) . unfoldr chunk . BS8.lines
src/Distribution/Client/BuildReports/Storage.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -----------------------------------------------------------------------------  -----------------------------------------------------------------------------@@ -91,13 +89,15 @@     separate       :: [(BuildReport, Maybe Repo)]       -> [(Repo, [BuildReport])]-    separate =-      map (\rs@((_, repo, _) : _) -> (repo, [r | (r, _, _) <- rs]))-        . map (concatMap toList)-        . L.groupBy (equating (repoName' . head))-        . sortBy (comparing (repoName' . head))-        . groupBy (equating repoName')-        . onlyRemote+    separate xs =+      [ (repo, [r | (r, _, _) <- rs])+      | rs@((_, repo, _) : _) <-+          map (concatMap toList)+            . L.groupBy (equating (repoName' . head))+            . sortBy (comparing (repoName' . head))+            . groupBy (equating repoName')+            $ onlyRemote xs+      ]      repoName' (_, _, rrepo) = remoteRepoName rrepo @@ -148,10 +148,10 @@             cinfo             platform -    groupByFileName =-      map (\grp@((filename, _) : _) -> (filename, map snd grp))-        . L.groupBy (equating fst)-        . sortBy (comparing fst)+    groupByFileName xs =+      [ (filename, map snd grp)+      | grp@((filename, _) : _) <- L.groupBy (equating fst) $ sortBy (comparing fst) xs+      ]  -- ------------------------------------------------------------
src/Distribution/Client/BuildReports/Types.hs view
@@ -39,6 +39,7 @@   deriving (Eq, Ord, Enum, Bounded, Show, Generic)  instance Binary ReportLevel+instance NFData ReportLevel instance Structured ReportLevel  instance Pretty ReportLevel where
src/Distribution/Client/BuildReports/Upload.hs view
@@ -21,6 +21,7 @@ -} import Network.URI (URI, uriPath) -- parseRelativeReference, relativeTo) +import Data.Foldable (forM_) import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.Errors@@ -41,9 +42,7 @@ uploadReports verbosity repoCtxt auth uri reports = do   for_ reports $ \(report, mbBuildLog) -> do     buildId <- postBuildReport verbosity repoCtxt auth uri report-    case mbBuildLog of-      Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog-      Nothing -> return ()+    forM_ mbBuildLog (putBuildLog verbosity repoCtxt auth buildId)  postBuildReport :: Verbosity -> RepoContext -> Auth -> URI -> BuildReport -> IO BuildReportId postBuildReport verbosity repoCtxt auth uri buildReport = do
src/Distribution/Client/Check.hs view
@@ -16,19 +16,16 @@ import Prelude ()  import Distribution.Client.Errors-import Distribution.Client.Utils.Parsec (renderParseError)++import Distribution.Client.Errors.Parser+import Distribution.Fields.ParseResult import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Check import Distribution.PackageDescription.Parsec-  ( parseGenericPackageDescription-  , runParseResult-  )-import Distribution.Parsec (PWarning (..), showPError)+import Distribution.Parsec import Distribution.Simple.Utils (defaultPackageDescCwd, dieWithException, notice, warn, warnError) import Distribution.Utils.Path (getSymbolicPath) -import System.IO (hPutStr, stderr)- import qualified Control.Monad as CM import qualified Data.ByteString as BS import qualified Data.Function as F@@ -36,19 +33,17 @@ import qualified Data.List.NonEmpty as NE import qualified System.Directory as Dir -readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)+readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarningWithSource CabalFileSource], GenericPackageDescription) readGenericPackageDescriptionCheck verbosity fpath = do   exists <- Dir.doesFileExist fpath   unless exists $     dieWithException verbosity $       FileDoesntExist fpath   bs <- BS.readFile fpath-  let (warnings, result) = runParseResult (parseGenericPackageDescription bs)+  let (warnings, result) = runParseResult $ withSource (PCabalFile (fpath, bs)) (parseGenericPackageDescription bs)   case result of-    Left (_, errors) -> do-      traverse_ (warn verbosity . showPError fpath) errors-      hPutStr stderr $ renderParseError fpath bs errors warnings-      dieWithException verbosity ParseError+    Left (mspecVersion, errors) -> do+      dieWithException verbosity (CabalCheckParseError (CabalFileParseError fpath bs errors mspecVersion warnings))     Right x -> return (warnings, x)  -- | Checks a package for common errors. Returns @True@ if the package@@ -65,7 +60,7 @@   pdfile <- getSymbolicPath <$> defaultPackageDescCwd verbosity   (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile   -- convert parse warnings into PackageChecks-  let ws' = map (wrapParseWarning pdfile) ws+  let ws' = map (wrapParseWarning pdfile . pwarning) ws   ioChecks <- checkPackageFilesGPD verbosity ppd "."   let packageChecksPrim = ioChecks ++ checkPackage ppd ++ ws'       (packageChecks, unrecs) = filterPackageChecksByIdString packageChecksPrim ignores
src/Distribution/Client/CmdClean.hs view
@@ -50,8 +50,8 @@   ) import Distribution.Simple.Utils   ( dieWithException-  , handleDoesNotExist   , info+  , removeFileForcibly   , wrapText   ) import Distribution.System@@ -63,9 +63,15 @@   , (</>)   ) import Distribution.Verbosity-  ( normal+  ( VerbosityFlags+  , defaultVerbosityHandles+  , mkVerbosity+  , normal   ) +import Control.Concurrent+  ( threadDelay+  ) import Control.Exception   ( throw   )@@ -75,27 +81,26 @@   , mapM   ) import qualified Data.Set as Set+import qualified GHC.IO.Exception as GHC import System.Directory   ( canonicalizePath   , doesDirectoryExist   , doesFileExist-  , getDirectoryContents   , listDirectory-  , removeDirectoryRecursive-  , removeFile   , removePathForcibly   ) import System.FilePath   ( (</>)   ) import System.IO.Error-  ( isPermissionError+  ( ioeGetErrorType+  , isPermissionError   ) import qualified System.Process as Process  data CleanFlags = CleanFlags   { cleanSaveConfig :: Flag Bool-  , cleanVerbosity :: Flag Verbosity+  , cleanVerbosity :: Flag VerbosityFlags   , cleanDistDir :: Flag (SymbolicPath Pkg (Dir Dist))   }   deriving (Eq)@@ -149,7 +154,7 @@  cleanAction :: (ProjectFlags, CleanFlags) -> [String] -> GlobalFlags -> IO () cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do-  let verbosity = fromFlagOrDefault normal cleanVerbosity+  let verbosity = mkVerbosity defaultVerbosityHandles $ fromFlagOrDefault normal cleanVerbosity       saveConfig = fromFlagOrDefault False cleanSaveConfig       mdistDirectory = fmap getSymbolicPath $ flagToMaybe cleanDistDir       mprojectDir = flagToMaybe flagProjectDir@@ -177,23 +182,27 @@          when buildRootExists $ do           info verbosity ("Deleting build root (" ++ buildRoot ++ ")")-          handleDoesNotExist () $ removeDirectoryRecursive buildRoot+          removePathForcibly buildRoot       else do         let distRoot = distDirectory distLayout          info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")-        handleDoesNotExist () $ do-          if buildOS == Windows-            then do-              -- Windows can't delete some git files #10182-              void $-                Process.createProcess_ "attrib" $-                  Process.shell $-                    "attrib -s -h -r " <> distRoot <> "\\*.* /s /d"-              catch-                (removePathForcibly distRoot)-                (\e -> if isPermissionError e then removePathForcibly distRoot else throw e)-            else removeDirectoryRecursive distRoot+        -- Windows can't delete some git files #10182+        when (buildOS == Windows) $+          void $+            Process.createProcess_ "attrib" $+              Process.shell $+                "attrib -s -h -r " <> distRoot <> "\\*.* /s /d"+        catch+          (removePathForcibly distRoot)+          ( \e ->+              -- Permission error is usually when some files are (temporarily) locked.+              -- Unsatisfied constraints (directory is non empty) error happens+              -- when some files inside the directory were not removed (perhaps because they are locked).+              if isPermissionError e || ioeGetErrorType e == GHC.UnsatisfiedConstraints+                then threadDelay 1000 >> removePathForcibly distRoot+                else throw e+          )      removeEnvFiles $ distProjectRootDirectory distLayout @@ -212,9 +221,9 @@     exists <- doesFileExist script     when (not exists || script `Set.member` toClean) $ do       info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")-      removeDirectoryRecursive cache+      removePathForcibly cache  removeEnvFiles :: FilePath -> IO () removeEnvFiles dir =-  (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))-    =<< getDirectoryContents dir+  (traverse_ (removeFileForcibly . (dir </>)) . filter ((".ghc.environment" ==) . take 16))+    =<< listDirectory dir
src/Distribution/Client/CmdConfigure.hs view
@@ -49,6 +49,7 @@  import Distribution.Client.DistDirLayout   ( DistDirLayout (..)+  , ProjectFileKey (ProjectFileKeyLocal)   ) import Distribution.Client.Errors import Distribution.Client.HttpUtils@@ -131,7 +132,7 @@    baseCtx <- establishProjectBaseContext v cliConfig OtherCommand -  let localFile = distProjectFile (distDirLayout baseCtx) "local"+  let localFile = distProjectFile (distDirLayout baseCtx) ProjectFileKeyLocal   -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~   let backups = fromFlagOrDefault True $ configBackup configExFlags       appends = fromFlagOrDefault False $ configAppend configExFlags@@ -157,10 +158,14 @@               v               (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)               (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)-          (CondNode conf imps bs) <-+          (CondNode (imps, conf) bs) <-             runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $-              readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx)-          when (not (null imps && null bs)) $ dieWithException v UnableToPerformInplaceUpdate+              readProjectLocalExtraConfig+                v+                (fromFlagOrDefault defaultProjectFileParser $ projectConfigProjectFileParser $ projectConfigShared cliConfig)+                httpTransport+                (distDirLayout baseCtx)+          unless (null imps && null bs) $ dieWithException v UnableToPerformInplaceUpdate           return (baseCtx, conf <> cliConfig)         else return (baseCtx, cliConfig)   where
src/Distribution/Client/CmdExec.hs view
@@ -250,7 +250,6 @@   let tmpDirTemplate = distTempDirectory (distDirLayout baseCtx)   createDirectoryIfMissingVerbose verbosity True tmpDirTemplate   withTempDirectory-    verbosity     tmpDirTemplate     "environment."     ( \tmpDir -> do
src/Distribution/Client/CmdFreeze.hs view
@@ -12,6 +12,7 @@  import Distribution.Client.DistDirLayout   ( DistDirLayout (distProjectFile)+  , ProjectFileKey (ProjectFileKeyFreeze)   ) import Distribution.Client.IndexUtils (ActiveRepos, TotalIndexState, filterSkippedActiveRepos) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -157,7 +158,7 @@     else do       writeProjectLocalFreezeConfig distDirLayout freezeConfig       notice verbosity $-        "Wrote freeze file: " ++ (distProjectFile distDirLayout "freeze")+        "Wrote freeze file: " ++ distProjectFile distDirLayout ProjectFileKeyFreeze   where     verbosity = cfgVerbosity normal flags     cliConfig =
src/Distribution/Client/CmdGenBounds.hs view
@@ -147,7 +147,7 @@     -- Process each package to find the ones needing bounds     let boundsActions = concatMap genBoundsActionForPkg localPkgs -    if (any isBoundsNeeded boundsActions)+    if any isBoundsNeeded boundsActions       then do         notice verbosity boundsNeededMsg         mapM_ (renderBoundsResult verbosity) boundsActions@@ -200,7 +200,7 @@     -- \* the dependency does not have an upper bound     -- \* the dependency is not the same package as the one we are processing     boundFilter dep =-      (not (hasUpperBound (depVerRange dep)))+      not (hasUpperBound (depVerRange dep))         && packageName pd /= depPkgName dep      -- The dependencies that need bounds.
src/Distribution/Client/CmdHaddockProject.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-}  module Distribution.Client.CmdHaddockProject@@ -106,7 +107,9 @@ import Distribution.Types.Version (mkVersion) import Distribution.Types.VersionRange (orLaterVersion) import Distribution.Verbosity as Verbosity-  ( normal+  ( defaultVerbosityHandles+  , mkVerbosity+  , normal   )  import Distribution.Client.Errors@@ -213,120 +216,121 @@       -- Copy haddocks to the destination folder       -- -      packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->-        case pkg of-          Left package | localStyle -> do-            let packageName = unPackageName (pkgName $ sourcePackageId package)-                destDir = outputDir </> packageName-            fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do-              let docDir = takeDirectory interfacePath-              a <- doesFileExist interfacePath-              case a of+      packageInfos <- fmap (nub . concat) $+        for pkgs $+          \case+            Left package | localStyle -> do+              let packageName = unPackageName (pkgName $ sourcePackageId package)+                  destDir = outputDir </> packageName+              fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do+                let docDir = takeDirectory interfacePath+                a <- doesFileExist interfacePath+                case a of+                  True -> do+                    copyDirectoryRecursive verbosity docDir destDir+                    return $ Just $ Right (packageName, interfacePath, Hidden)+                  False -> return Nothing+            Left _ -> return []+            Right package ->+              case elabLocalToProject package of                 True -> do-                  copyDirectoryRecursive verbosity docDir destDir-                  return $ Just $ Right (packageName, interfacePath, Hidden)-                False -> return Nothing-          Left _ -> return []-          Right package ->-            case elabLocalToProject package of-              True -> do-                let distDirParams = elabDistDirParams sharedConfig' package-                    pkg_descr = elabPkgDescription package+                  let distDirParams = elabDistDirParams sharedConfig' package+                      pkg_descr = elabPkgDescription package -                    packageName = pkgName $ elabPkgSourceId package-                    unitId = elabUnitId package-                    packageDir = haddockDirName ForDevelopment pkg_descr-                    destDir = outputDir </> packageDir-                    interfacePath = destDir </> haddockPath pkg_descr+                      packageName = pkgName $ elabPkgSourceId package+                      unitId = elabUnitId package+                      packageDir = haddockDirName ForDevelopment pkg_descr+                      destDir = outputDir </> packageDir+                      interfacePath = destDir </> haddockPath pkg_descr -                    buildDir = distBuildDirectory distLayout distDirParams-                    docDir =-                      buildDir-                        </> "doc"-                        </> "html"-                        </> packageDir+                      buildDir = distBuildDirectory distLayout distDirParams+                      docDir =+                        buildDir+                          </> "doc"+                          </> "html"+                          </> packageDir -                a <- doesDirectoryExist docDir-                if a-                  then do-                    copyDirectoryRecursive verbosity docDir destDir-                    let infos :: [(String, FilePath, Visibility)]-                        infos =-                          (unPackageName packageName, interfacePath, Visible)-                            : [ (sublibDirPath, sublibInterfacePath, Visible)-                              | lib <- subLibraries pkg_descr-                              , let sublibDirPath = haddockLibraryDirPath ForDevelopment pkg_descr lib-                                    sublibInterfacePath =-                                      outputDir-                                        </> sublibDirPath-                                        </> haddockLibraryPath pkg_descr lib-                              ]-                            ++ [ (testPath, testInterfacePath, Visible)-                               | test <- testSuites pkg_descr-                               , let testPath = haddockTestDirPath ForDevelopment pkg_descr test-                                     testInterfacePath =-                                      outputDir-                                        </> testPath-                                        </> haddockPath pkg_descr-                               ]-                            ++ [ (benchPath, benchInterfacePath, Visible)-                               | bench <- benchmarks pkg_descr-                               , let benchPath = haddockBenchmarkDirPath ForDevelopment pkg_descr bench-                                     benchInterfacePath =-                                      outputDir-                                        </> benchPath-                                        </> haddockPath pkg_descr-                               ]-                    infos' <--                      mapM-                        ( \x@(_, path, _) -> do-                            e <- doesFileExist path-                            return $-                              if e-                                then Right x-                                else Left path+                  a <- doesDirectoryExist docDir+                  if a+                    then do+                      copyDirectoryRecursive verbosity docDir destDir+                      let infos :: [(String, FilePath, Visibility)]+                          infos =+                            (unPackageName packageName, interfacePath, Visible)+                              : [ (sublibDirPath, sublibInterfacePath, Visible)+                                | lib <- subLibraries pkg_descr+                                , let sublibDirPath = haddockLibraryDirPath ForDevelopment pkg_descr lib+                                      sublibInterfacePath =+                                        outputDir+                                          </> sublibDirPath+                                          </> haddockLibraryPath pkg_descr lib+                                ]+                              ++ [ (testPath, testInterfacePath, Visible)+                                 | test <- testSuites pkg_descr+                                 , let testPath = haddockTestDirPath ForDevelopment pkg_descr test+                                       testInterfacePath =+                                        outputDir+                                          </> testPath+                                          </> haddockPath pkg_descr+                                 ]+                              ++ [ (benchPath, benchInterfacePath, Visible)+                                 | bench <- benchmarks pkg_descr+                                 , let benchPath = haddockBenchmarkDirPath ForDevelopment pkg_descr bench+                                       benchInterfacePath =+                                        outputDir+                                          </> benchPath+                                          </> haddockPath pkg_descr+                                 ]+                      infos' <-+                        mapM+                          ( \x@(_, path, _) -> do+                              e <- doesFileExist path+                              return $+                                if e+                                  then Right x+                                  else Left path+                          )+                          infos+                      return infos'+                    else do+                      warn+                        verbosity+                        ( "haddocks of "+                            ++ unUnitId unitId+                            ++ " not found in the store"                         )-                        infos-                    return infos'-                  else do-                    warn-                      verbosity-                      ( "haddocks of "-                          ++ unUnitId unitId-                          ++ " not found in the store"-                      )-                    return []-              False-                | not localStyle ->-                    return []-              False -> do-                let pkg_descr = elabPkgDescription package-                    unitId = unUnitId (elabUnitId package)-                    packageDir =-                      storePackageDirectory-                        (cabalStoreDirLayout cabalLayout)-                        (pkgConfigCompiler sharedConfig')-                        (elabUnitId package)-                    -- TODO: use `InstallDirTemplates`-                    docDir = packageDir </> "share" </> "doc" </> "html"-                    destDir = outputDir </> haddockDirName ForDevelopment pkg_descr-                    interfacePath = destDir </> haddockPath pkg_descr-                a <- doesDirectoryExist docDir-                case a of-                  True -> do-                    copyDirectoryRecursive verbosity docDir destDir-                    -- non local packages will be hidden in haddock's-                    -- generated contents page-                    return [Right (unitId, interfacePath, Hidden)]-                  False -> do-                    return [Left unitId]+                      return []+                False+                  | not localStyle ->+                      return []+                False -> do+                  let pkg_descr = elabPkgDescription package+                      unitId = unUnitId (elabUnitId package)+                      packageDir =+                        storePackageDirectory+                          (cabalStoreDirLayout cabalLayout)+                          (pkgConfigCompiler sharedConfig')+                          (elabUnitId package)+                      -- TODO: use `InstallDirTemplates`+                      docDir = packageDir </> "share" </> "doc" </> "html"+                      destDir = outputDir </> haddockDirName ForDevelopment pkg_descr+                      interfacePath = destDir </> haddockPath pkg_descr+                  a <- doesDirectoryExist docDir+                  case a of+                    True -> do+                      copyDirectoryRecursive verbosity docDir destDir+                      -- non local packages will be hidden in haddock's+                      -- generated contents page+                      return [Right (unitId, interfacePath, Hidden)]+                    False -> do+                      return [Left unitId]        --       -- generate index, content, etc.       --        let (missingHaddocks, packageInfos') = partitionEithers packageInfos-      when (not (null missingHaddocks)) $ do+      unless (null missingHaddocks) $ do         warn verbosity "missing haddocks for some packages from the store"         -- Show the package list if `-v1` is passed; it's usually a long list.         -- One needs to add `package` stantza in `cabal.project` file for@@ -359,7 +363,9 @@     -- build all packages with appropriate haddock flags     commonFlags = haddockProjectCommonFlags flags -    verbosity = fromFlagOrDefault normal (setupVerbosity commonFlags)+    verbosity =+      mkVerbosity defaultVerbosityHandles $+        fromFlagOrDefault normal (setupVerbosity commonFlags)      haddockFlags =       defaultHaddockFlags@@ -417,7 +423,7 @@     -- provide location of the documentation of dependencies.     localStyle =       let hackage = fromFlagOrDefault False (haddockProjectHackage flags)-          location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags)+          location = fromFlagOrDefault False (True <$ haddockProjectHtmlLocation flags)        in not hackage && not location      reportTargetProblems :: Show x => [x] -> IO a
src/Distribution/Client/CmdInstall.hs view
@@ -21,9 +21,6 @@   ) where  import Distribution.Client.Compat.Prelude-import Distribution.Compat.Directory-  ( doesPathExist-  ) import Prelude ()  import Distribution.Client.CmdErrorMessages@@ -218,6 +215,7 @@   ) import Distribution.Verbosity   ( lessVerbose+  , modifyVerbosityFlags   , normal   ) @@ -238,10 +236,10 @@   , createDirectoryIfMissing   , doesDirectoryExist   , doesFileExist+  , doesPathExist   , getTemporaryDirectory   , makeAbsolute-  , removeDirectory-  , removeFile+  , removePathForcibly   ) import System.FilePath   ( takeBaseName@@ -331,7 +329,7 @@     }   where     -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.-    notInstallDirOpt x = not $ optionName x `elem` installDirOptNames+    notInstallDirOpt x = optionName x `notElem` installDirOptNames     installDirOptNames = map optionName installDirsOptions  -- | The @install@ command actually serves four different needs. It installs:@@ -462,7 +460,7 @@   -- temporary dist directory.   globalTmp <- getTemporaryDirectory -  withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do+  withTempDirectory globalTmp "cabal-install." $ \tmpDir -> do     distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir      uriSpecs <-@@ -595,7 +593,7 @@           concatMap (targetPkgNames $ localPackages baseCtx) targetSelectors   return (pkgSpecs, targetSelectors, config)   where-    reducedVerbosity = lessVerbose verbosity+    reducedVerbosity = modifyVerbosityFlags lessVerbose verbosity      -- We take the targets and try to parse them as package ids (with name and version).     -- The ones who don't parse will have to be resolved in the project context.@@ -625,7 +623,7 @@   -> Maybe ComponentKindFilter   -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targetFilter = do-  let reducedVerbosity = lessVerbose verbosity+  let reducedVerbosity = modifyVerbosityFlags lessVerbose verbosity    sourcePkgDb <-     projectConfigWithBuilderRepoContext@@ -854,7 +852,7 @@               dieWithException verbosity $ UnknownPackage (unPackageName hn) (("- " ++) . unPackageName . fst <$> xs)         _ -> return () -      when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'+      unless (null errs') $ reportBuildTargetProblems verbosity errs'        let         targetSelectors' = flip filter targetSelectors $ \case@@ -993,7 +991,7 @@               . take 1               . sortBy (comparing (Down . fst))               . PI.lookupPackageName installedIndex-          globalLatest = concat (getLatest <$> globalPackages)+          globalLatest = concatMap getLatest globalPackages           globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest           baseEntries =             GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs@@ -1061,10 +1059,7 @@     targets = concat $ Map.elems $ targetsMap buildCtx     components = fst <$> targets     selectors = concatMap (NE.toList . snd) targets-    noExes = null $ catMaybes $ exeMaybe <$> components--    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe-    exeMaybe _ = Nothing+    noExes = not $ any (isJust . exeMaybe) components  -- | Return the package specifiers and non-global environment file entries. getEnvSpecsAndNonGlobalEntries@@ -1133,6 +1128,10 @@       (mkFinalExeName exe)       (mkExeName exe) +exeMaybe :: ComponentTarget -> Maybe UnqualComponentName+exeMaybe (ComponentTarget (CExeName exe) _) = Just exe+exeMaybe _ = Nothing+ -- | -- -- * When 'InstallCheckOnly', warn if install would fail overwrite policy --      checks but don't install anything.@@ -1154,9 +1153,7 @@           then traverse_ installAndWarn exes           else traverse_ warnAbout (zip symlinkables exes)     where-      exes = catMaybes $ (exeMaybe . fst) <$> components-      exeMaybe (ComponentTarget (CExeName exe) _) = Just exe-      exeMaybe _ = Nothing+      exes = mapMaybe (exeMaybe . fst) components        warnAbout (True, _) = return ()       warnAbout (False, exe) = dieWithException verbosity $ InstallUnitExes (errorMessage installDir exe)@@ -1238,14 +1235,9 @@     where       source = sourceDir </> exeName       destination = installdir </> finalExeName-      remove = do-        isDir <- doesDirectoryExist destination-        if isDir-          then removeDirectory destination-          else removeFile destination       copy = copyFile source destination >> pure True       overwrite :: IO Bool-      overwrite = remove >> copy+      overwrite = removePathForcibly destination >> copy       maybeOverwrite :: IO Bool       maybeOverwrite =         promptRun
src/Distribution/Client/CmdInstall/ClientInstallFlags.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}  module Distribution.Client.CmdInstall.ClientInstallFlags@@ -6,9 +8,12 @@   , ClientInstallFlags (..)   , defaultClientInstallFlags   , clientInstallOptions+  , clientInstallFlagsGrammar   ) where  import Distribution.Client.Compat.Prelude+import Distribution.Compat.Lens (Lens')+import Distribution.FieldGrammar import Prelude ()  import Distribution.ReadE@@ -35,6 +40,7 @@ import Distribution.Client.Types.OverwritePolicy   ( OverwritePolicy (..)   )+import Distribution.Client.Utils.Parsec  import qualified Distribution.Compat.CharParsing as P @@ -55,6 +61,7 @@   (<>) = gmappend  instance Binary ClientInstallFlags+instance NFData ClientInstallFlags instance Structured ClientInstallFlags  defaultClientInstallFlags :: ClientInstallFlags@@ -114,6 +121,25 @@       $ reqArg "DIR" (succeedReadE Flag) flagToList   ] +clientInstallFlagsGrammar+  :: ( FieldGrammar c g+     , c (Identity (Flag Bool))+     , c (Flag' FilePathNT FilePath)+     , c (Identity (Flag OverwritePolicy))+     , c (Identity (Flag InstallMethod))+     )+  => g ClientInstallFlags ClientInstallFlags+clientInstallFlagsGrammar =+  ClientInstallFlags+    <$> optionalFieldDef "lib" cinstInstallLibsLens mempty+    <*> ( optionalFieldDefAla "package-env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty+            <* optionalFieldDefAla "env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty+        )+    <*> optionalFieldDef "overwrite-policy" cinstOverwritePolicyLens mempty+    <*> optionalFieldDef "install-method" cinstInstallMethodLens mempty+    <*> optionalFieldDefAla "installdir" (alaFlag FilePathNT) cinstInstalldirLens mempty+{-# SPECIALIZE clientInstallFlagsGrammar :: ParsecFieldGrammar' ClientInstallFlags #-}+ parsecInstallMethod :: CabalParsing m => m InstallMethod parsecInstallMethod = do   name <- P.munch1 isAlpha@@ -121,3 +147,23 @@     "copy" -> pure InstallMethodCopy     "symlink" -> pure InstallMethodSymlink     _ -> P.unexpected $ "InstallMethod: " ++ name++cinstInstallLibsLens :: Lens' ClientInstallFlags (Flag Bool)+cinstInstallLibsLens f c = fmap (\x -> c{cinstInstallLibs = x}) (f (cinstInstallLibs c))+{-# INLINEABLE cinstInstallLibsLens #-}++cinstEnvironmentPathLens :: Lens' ClientInstallFlags (Flag FilePath)+cinstEnvironmentPathLens f c = fmap (\x -> c{cinstEnvironmentPath = x}) (f (cinstEnvironmentPath c))+{-# INLINEABLE cinstEnvironmentPathLens #-}++cinstOverwritePolicyLens :: Lens' ClientInstallFlags (Flag OverwritePolicy)+cinstOverwritePolicyLens f c = fmap (\x -> c{cinstOverwritePolicy = x}) (f (cinstOverwritePolicy c))+{-# INLINEABLE cinstOverwritePolicyLens #-}++cinstInstallMethodLens :: Lens' ClientInstallFlags (Flag InstallMethod)+cinstInstallMethodLens f c = fmap (\x -> c{cinstInstallMethod = x}) (f (cinstInstallMethod c))+{-# INLINEABLE cinstInstallMethodLens #-}++cinstInstalldirLens :: Lens' ClientInstallFlags (Flag FilePath)+cinstInstalldirLens f c = fmap (\x -> c{cinstInstalldir = x}) (f (cinstInstalldir c))+{-# INLINEABLE cinstInstalldirLens #-}
src/Distribution/Client/CmdLegacy.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}  module Distribution.Client.CmdLegacy (legacyCmd, legacyWrapperCmd, newCmd) where @@ -14,7 +14,8 @@   ) import qualified Distribution.Client.Setup as Client import Distribution.Client.SetupWrapper-  ( SetupScriptOptions (..)+  ( SetupRunnerArgs (NotInLibrary)+  , SetupScriptOptions (..)   , defaultSetupScriptOptions   , setupWrapper   )@@ -24,7 +25,10 @@   ( wrapText   ) import Distribution.Verbosity-  ( normal+  ( VerbosityFlags+  , defaultVerbosityHandles+  , mkVerbosity+  , normal   )  import Control.Exception@@ -35,7 +39,7 @@ -- Tweaked versions of code from Main. regularCmd :: HasVerbosity flags => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) regularCmd ui action =-  CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand+  CommandSpec ui (`commandAddAction` (\flags extra globals -> action flags extra globals)) NormalCommand  wrapperCmd   :: Monoid flags@@ -43,7 +47,7 @@   -> (flags -> Setup.CommonSetupFlags)   -> CommandSpec (Client.GlobalFlags -> IO ()) wrapperCmd ui getCommonFlags =-  CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand+  CommandSpec ui (`wrapperAction` getCommonFlags) NormalCommand  wrapperAction   :: Monoid flags@@ -57,7 +61,9 @@       }     $ \flags extraArgs globalFlags -> do       let common = getCommonFlags flags-          verbosity' = Setup.fromFlagOrDefault normal (Setup.setupVerbosity common)+          verbosity' =+            mkVerbosity defaultVerbosityHandles $+              Setup.fromFlagOrDefault normal (Setup.setupVerbosity common)           mbWorkDir = Setup.flagToMaybe $ Setup.setupWorkingDir common        load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)@@ -79,13 +85,14 @@         getCommonFlags         (const (return flags))         (const extraArgs)+        NotInLibrary  --  class HasVerbosity a where-  verbosity :: a -> Verbosity+  verbosity :: a -> VerbosityFlags -instance HasVerbosity (Setup.Flag Verbosity) where+instance HasVerbosity (Setup.Flag VerbosityFlags) where   verbosity = Setup.fromFlagOrDefault normal  instance HasVerbosity a => HasVerbosity (a, b) where@@ -163,7 +170,7 @@ newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi]   where-    cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand+    cmd ui = CommandSpec ui (`commandAddAction` action) NormalCommand      newMsg = T.unpack . T.replace "v2-" "new-" . T.pack     newUi =
src/Distribution/Client/CmdListBin.hs view
@@ -52,7 +52,7 @@ import Distribution.Types.ComponentName (showComponentName) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName)-import Distribution.Verbosity (silent, verboseStderr)+import Distribution.Verbosity (silent, verboseStderr, verbosityFlags) import System.FilePath ((<.>), (</>))  import qualified Data.Map as Map@@ -155,7 +155,7 @@      case binfiles of       [] -> dieWithException verbosity NoTargetFound-      [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n"+      [exe] -> putStr $ withOutputMarker (verbosityFlags verbosity) $ exe ++ "\n"       -- Andreas, 2023-01-13, issue #8400:       -- Regular output of `list-bin` should go to stdout unconditionally,       -- but for the sake of the testsuite, we want to mark it so it goes@@ -377,12 +377,8 @@     ++ renderTargetSelector targetSelector     ++ " which includes "     ++ renderListCommaAnd-      ( ("the " ++)-          <$> showComponentName-          <$> availableTargetComponentName-          <$> foldMap-            (\kind -> filterTargetsKind kind targets)-            [ExeKind, TestKind, BenchKind]+      ( (("the " ++) <$> showComponentName) . availableTargetComponentName+          <$> foldMap (`filterTargetsKind` targets) [ExeKind, TestKind, BenchKind]       )     ++ "." renderListBinProblem (TargetProblemMultipleTargets selectorMap) =
src/Distribution/Client/CmdOutdated.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} @@ -264,17 +265,16 @@               deps               sourcePkgDb               (ListOutdatedSettings ignorePred minorPred)-      when (not quiet) $+      unless quiet $         showResult verbosity outdatedDeps simpleOutput-      if exitCode && (not . null $ outdatedDeps)-        then exitFailure-        else return ()+      when (exitCode && (not . null $ outdatedDeps)) exitFailure   where     OutdatedFlags{..} = extraFlags flags     verbosity =-      if quiet-        then silent-        else fromFlagOrDefault normal (setupVerbosity (configCommonFlags (configFlags flags)))+      mkVerbosity defaultVerbosityHandles $+        if quiet+          then silent+          else fromFlagOrDefault normal (setupVerbosity (configCommonFlags (configFlags flags)))     freezeFile = fromFlagOrDefault False outdatedFreezeFile     newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile     simpleOutput = fromFlagOrDefault False outdatedSimpleOutput@@ -282,14 +282,14 @@     exitCode = fromFlagOrDefault quiet outdatedExitCode     ignorePred =       let ignoreSet = S.fromList outdatedIgnore-       in \pkgname -> pkgname `S.member` ignoreSet+       in (`S.member` ignoreSet)     minorPred = case outdatedMinor of       Nothing -> const False       Just IgnoreMajorVersionBumpsNone -> const False       Just IgnoreMajorVersionBumpsAll -> const True       Just (IgnoreMajorVersionBumpsSome pkgs) ->         let minorSet = S.fromList pkgs-         in \pkgname -> pkgname `S.member` minorSet+         in (`S.member` minorSet)  reportOutdatedTargetProblem :: Verbosity -> [TargetProblem'] -> IO a reportOutdatedTargetProblem verbosity problems =@@ -301,7 +301,7 @@ showResult verbosity outdatedDeps simpleOutput =   if not . null $ outdatedDeps     then do-      when (not simpleOutput) $+      unless simpleOutput $         notice verbosity "Outdated dependencies:"       if simpleOutput         then -- Simple output just prints package names, one per line@@ -323,7 +323,7 @@         pkgGroups =           Map.fromListWith             (Map.unionWith (++))-            [ (pkg, (Map.singleton comp [d]))+            [ (pkg, Map.singleton comp [d])             | (pkg, comp, d) <- pkgCompDeps             ]        in@@ -397,7 +397,7 @@ -- | Convert a list of 'UserConstraint's to a 'Dependency' list. userConstraintsToDependencies :: [(UserConstraint, ConstraintSource)] -> [CandidateOutdatedDependency] userConstraintsToDependencies ucnstrs =-  mapMaybe (\(uc, src) -> fmap (flip mkCandidateOutdatedDependency (ConfigSource src)) (packageConstraintToDependency . userToPackageConstraint $ uc)) ucnstrs+  mapMaybe (\(uc, src) -> fmap (`mkCandidateOutdatedDependency` ConfigSource src) (packageConstraintToDependency . userToPackageConstraint $ uc)) ucnstrs  -- | Read the list of dependencies from the freeze file. depsFromFreezeFile :: Verbosity -> IO [CandidateOutdatedDependency]@@ -496,7 +496,7 @@ selectPackageTargetsForOutdated   :: TargetSelector   -> [AvailableTarget k]-  -> Either (TargetProblem') [k]+  -> Either TargetProblem' [k] selectPackageTargetsForOutdated targetSelector targets   -- No targets available at all is an error   | null targets = Left (TargetProblemNoTargets targetSelector)@@ -508,7 +508,7 @@ selectComponentTargetForOutdated   :: SubComponentTarget   -> AvailableTarget k-  -> Either (TargetProblem') k+  -> Either TargetProblem' k selectComponentTargetForOutdated subtarget target =   selectComponentTargetBasic subtarget target @@ -524,7 +524,7 @@         selectComponentTargetForOutdated         (localPackages ctx)         targetSelectors-  fmap concat <$> forM (localPackages ctx) $ \pkg -> case pkg of+  fmap concat <$> forM (localPackages ctx) $ \case     SpecificSourcePackage pkg' -> do       -- Find the package in the resolved targets       let pkgId = packageId pkg'
src/Distribution/Client/CmdPath.hs view
@@ -81,6 +81,7 @@   ) import Distribution.Verbosity   ( normal+  , verbosityFlags   )  -------------------------------------------------------------------------------@@ -235,7 +236,7 @@               , pathDirectories = Flag [minBound .. maxBound]               }           else pathFlags'-  when (not $ null cliTargetStrings) $+  unless (null cliTargetStrings) $     dieWithException verbosity CmdPathAcceptsNoTargets   when (buildSettingDryRun (buildSettings baseCtx)) $     dieWithException verbosity CmdPathCommandDoesn'tSupportDryRun@@ -257,7 +258,7 @@         pure $ Just compilerInfo'    paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do-    t <- getPathLocation baseCtx p+    t <- getPathLocation verbosity baseCtx p     pure (pathName p, t)    let pathOutputs =@@ -272,27 +273,27 @@         KeyValue -> do           showAsKeyValuePair pathOutputs -  putStr $ withOutputMarker verbosity output+  putStr $ withOutputMarker (verbosityFlags verbosity) output   where     verbosity = cfgVerbosity normal flags  -- | Find the FilePath location for common configuration paths. -- -- TODO: this should come from a common source of truth to avoid code path divergence-getPathLocation :: ProjectBaseContext -> ConfigPath -> IO FilePath-getPathLocation _ ConfigPathCacheHome =+getPathLocation :: Verbosity -> ProjectBaseContext -> ConfigPath -> IO FilePath+getPathLocation _ _ ConfigPathCacheHome =   defaultCacheHome-getPathLocation baseCtx ConfigPathRemoteRepoCache =+getPathLocation _ baseCtx ConfigPathRemoteRepoCache =   pure $ buildSettingCacheDir (buildSettings baseCtx)-getPathLocation baseCtx ConfigPathLogsDir =+getPathLocation _ baseCtx ConfigPathLogsDir =   pure $ cabalLogsDirectory (cabalDirLayout baseCtx)-getPathLocation baseCtx ConfigPathStoreDir =+getPathLocation _ baseCtx ConfigPathStoreDir =   fromFlagOrDefault     defaultStoreDir     (pure <$> projectConfigStoreDir (projectConfigShared (projectConfig baseCtx)))-getPathLocation baseCtx ConfigPathConfigFile =-  getConfigFilePath (projectConfigConfigFile (projectConfigShared (projectConfig baseCtx)))-getPathLocation baseCtx ConfigPathInstallDir =+getPathLocation verbosity baseCtx ConfigPathConfigFile =+  getConfigFilePath verbosity (projectConfigConfigFile (projectConfigShared (projectConfig baseCtx)))+getPathLocation _ baseCtx ConfigPathInstallDir =   fromFlagOrDefault     defaultInstallPath     (pure <$> cinstInstalldir (projectConfigClientInstallFlags $ projectConfigBuildOnly (projectConfig baseCtx)))@@ -358,7 +359,7 @@      pathsJson = Json.object $ map (\(k, v) -> k .= Json.String v) (pathOutputsConfigPaths pathOutputs)    in-    mergeJsonObjects $+    mergeJsonObjects       [ cabalInstallJson       , compilerInfoJson       , pathsJson@@ -395,9 +396,7 @@ showAsKeyValuePair :: PathOutputs -> String showAsKeyValuePair pathOutputs =   let-    cInfo = case pathOutputsCompilerInfo pathOutputs of-      Nothing -> []-      Just pci -> compilerInfoToKeyValue pci+    cInfo = maybe [] compilerInfoToKeyValue (pathOutputsCompilerInfo pathOutputs)      paths = pathOutputsConfigPaths pathOutputs
src/Distribution/Client/CmdRepl.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}  -- | cabal-install CLI command: repl@@ -63,6 +64,7 @@ import Distribution.Client.ScriptUtils   ( AcceptNoTargets (..)   , TargetContext (..)+  , TargetsAction   , fakeProjectSourcePackage   , lSrcpkgDescription   , updateContextAndWriteProjectFile@@ -113,6 +115,7 @@ import Distribution.Simple.Utils   ( debugNoWrap   , dieWithException+  , notice   , withTempDirectoryEx   , wrapText   )@@ -157,6 +160,7 @@   ) import Distribution.Verbosity   ( lessVerbose+  , modifyVerbosityFlags   , normal   ) import Language.Haskell.Extension@@ -207,8 +211,9 @@     , commandUsage = usageAlternatives "v2-repl" ["[TARGET] [FLAGS]"]     , commandDescription = Just $ \_ ->         wrapText $-          "Open an interactive session for a component within the project. The "-            ++ "available targets are the same as for the 'v2-build' command: "+          "Open an interactive session for a single component within the project "+            ++ "or for multiple components at once if multi-repl is enabled.\n\n"+            ++ "The available targets are the same as for the 'v2-build' command: "             ++ "individual components within packages in the project, including "             ++ "libraries, executables, test-suites or benchmarks. Packages can "             ++ "also be specified in which case the library component in the "@@ -250,6 +255,10 @@           ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"           ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "           ++ "to the default component (or no component if there is no project present)\n"+          ++ "  "+          ++ pname+          ++ " repl pkg:cabal-install-solver pkg:Cabal-syntax --enable-multi-repl\n"+          ++ "    for default (in this case library) components in two packages\n"     , commandDefaultFlags = defaultNixStyleFlags defaultReplFlags     , commandOptions = nixStyleOptions topReplOptions     }@@ -273,6 +282,16 @@     -- a repl specific option.     (fromFlagOrDefault False (projectConfigMultiRepl ctx <> replUseMulti flags)) +-- | A function that resolves targets within a project context. The input target+-- selectors may be empty with a project in which case a default target is+-- chosen. The input target selectors must be empty with a global context that+-- will construct a fake package target. For a script context, the input target+-- selectors must contain only one element.+type TargetResolver = ProjectBaseContext -> [TargetSelector] -> IO ResolvedTargets++-- | Targets resolved from target strings with context and multi-repl flag.+type ResolvedTargets = ((ProjectBaseContext, Bool), [TargetSelector])+ -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- repl target and then executes the plan.@@ -284,74 +303,115 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO ()-replAction flags@NixStyleFlags{extraFlags = replFlags@ReplFlags{..}, configFlags} targetStrings globalFlags = do-  withCtx verbosity targetStrings $ \targetCtx ctx userTargetSelectors -> do+replAction flags targetStrings globalFlags =+  withCtx flags targetStrings globalFlags $ \targetCtx ctx selectors -> do     when (buildSettingOnlyDeps (buildSettings ctx)) $-      dieWithException verbosity ReplCommandDoesn'tSupport-    let projectRoot = distProjectRootDirectory $ distDirLayout ctx-        distDir = distDirectory $ distDirLayout ctx+      dieWithException (cfgVerbosity normal flags) ReplCommandDoesn'tSupport+    let resolveTarget = case targetCtx of+          ProjectContext -> resolveProjectTarget+          GlobalContext -> resolveGlobalTarget+          ScriptContext path exe -> resolveScriptTarget path exe+    resolvedTargets <- resolveTarget flags targetStrings ctx selectors+    targetedRepl flags targetCtx ctx resolvedTargets -    -- After ther user selectors have been resolved, and it's decided what context-    -- we're in, implement repl-specific behaviour.-    (baseCtx, targetSelectors) <- case targetCtx of-      -- If in the project context, and no selectors are provided-      -- then produce an error.-      ProjectContext -> do-        let projectFile = projectConfigProjectFile . projectConfigShared $ projectConfig ctx-        let pkgs = projectPackages $ projectConfig ctx-        case userTargetSelectors of-          [] ->-            dieWithException verbosity $-              RenderReplTargetProblem [render (reportProjectNoTarget projectFile pkgs)]-          _ -> return (ctx, userTargetSelectors)-      -- In the global context, construct a fake package which can be used to start-      -- a repl with extra arguments if `-b` is given.-      GlobalContext -> do-        unless (null userTargetSelectors) $-          dieWithException verbosity $-            ReplTakesNoArguments targetStrings-        let-          sourcePackage =-            fakeProjectSourcePackage projectRoot-              & lSrcpkgDescription . L.condLibrary-                .~ Just (CondNode library [baseDep] [])-          library = emptyLibrary{libBuildInfo = lBuildInfo}-          lBuildInfo =-            emptyBuildInfo-              { targetBuildDepends = [baseDep] ++ envPackages replEnvFlags-              , defaultLanguage = Just Haskell2010-              }-          baseDep = Dependency "base" anyVersion mainLibSet+resolveProjectTarget :: NixStyleFlags ReplFlags -> [String] -> TargetResolver+resolveProjectTarget flags@NixStyleFlags{extraFlags = ReplFlags{..}} targetStrings ctx userTargetSelectors = do+  case userTargetSelectors of+    [] -> do+      -- If in the project context with no selectors then for a target we:+      -- 1. pick the only package in the project+      -- 2. pick 'all' if multiple packages and multi-repl is enabled+      --+      -- We could have picked 'all' even for a single package project with+      -- multi-repl but that is not as specific.+      let projectFile = projectConfigProjectFile . projectConfigShared $ projectConfig ctx+      let pkgs = projectPackages $ projectConfig ctx+      case pkgs of+        [pkg] | pkg `notElem` targetStrings -> do+          retargetNotice ("package '" ++ pkg ++ "'")+          return (ctxMulti, [TargetPackageNamed (mkPackageName pkg) Nothing])+        _ ->+          if isMulti && not (null pkgs)+            then do+              retargetNotice "'all'"+              return (ctxMulti, [TargetAllPackages Nothing])+            else+              dieWithException verbosity $+                RenderReplTargetProblem [render (reportProjectNoTarget projectFile pkgs)]+    _ -> return (ctxMulti, userTargetSelectors)+  where+    verbosity = cfgVerbosity normal flags+    ctxMulti@(_, isMulti) = (ctx, isMultiReplEnabled replUseMulti ctx)+    retargetNotice newTarget =+      notice verbosity $+        "No target specified, using " ++ newTarget ++ " as the target for the REPL." -        -- Write the fake package-        updatedCtx <- updateContextAndWriteProjectFile' ctx sourcePackage-        -- Specify the selector for this package-        let fakeSelector = TargetPackage TargetExplicitNamed [fakePackageId] Nothing-        return (updatedCtx, [fakeSelector])+resolveGlobalTarget :: NixStyleFlags ReplFlags -> [String] -> TargetResolver+resolveGlobalTarget flags@NixStyleFlags{extraFlags = ReplFlags{..}} targetStrings ctx userTargetSelectors = do+  let projectRoot = distProjectRootDirectory $ distDirLayout ctx -      -- For the script context, no special behaviour.-      ScriptContext scriptPath scriptExecutable -> do-        unless (length targetStrings == 1) $-          dieWithException verbosity $-            ReplTakesSingleArgument targetStrings-        existsScriptPath <- doesFileExist scriptPath-        unless existsScriptPath $-          dieWithException verbosity $-            ReplTakesSingleArgument targetStrings+  -- In the global context, construct a fake package which can be used to start+  -- a repl with extra arguments if `-b` is given.+  do+    unless (null userTargetSelectors) $+      dieWithException (cfgVerbosity normal flags) $+        ReplTakesNoArguments targetStrings+    let+      sourcePackage =+        fakeProjectSourcePackage projectRoot+          & ( (lSrcpkgDescription . L.condLibrary)+                ?~ CondNode library []+            )+      library = emptyLibrary{libBuildInfo = lBuildInfo}+      lBuildInfo =+        emptyBuildInfo+          { targetBuildDepends = [baseDep] ++ envPackages replEnvFlags+          , defaultLanguage = Just Haskell2010+          }+      baseDep = Dependency "base" anyVersion mainLibSet -        updatedCtx <- updateContextAndWriteProjectFile ctx scriptPath scriptExecutable-        return (updatedCtx, userTargetSelectors)+    -- Write the fake package+    updatedCtx <- updateContextAndWriteProjectFile' ctx sourcePackage+    -- Specify the selector for this package+    let fakeSelector = TargetPackage TargetExplicitNamed [fakePackageId] Nothing+    return ((updatedCtx, isMultiReplEnabled replUseMulti updatedCtx), [fakeSelector]) -    -- 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 multiReplEnabled =-          fromFlagOrDefault False $-            projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx)-              <> replUseMulti+resolveScriptTarget :: FilePath -> L.Executable -> NixStyleFlags ReplFlags -> [String] -> TargetResolver+resolveScriptTarget scriptPath scriptExecutable flags@NixStyleFlags{extraFlags = ReplFlags{..}} targetStrings ctx userTargetSelectors = do+  -- For the script context, no special behaviour.+  do+    unless (length targetStrings == 1) $+      dieWithException verbosity $+        ReplTakesSingleArgument targetStrings+    existsScriptPath <- doesFileExist scriptPath+    unless existsScriptPath $+      dieWithException verbosity $+        ReplTakesSingleArgument targetStrings -        withReplEnabled =+    updatedCtx <- updateContextAndWriteProjectFile ctx scriptPath scriptExecutable+    return ((updatedCtx, isMultiReplEnabled replUseMulti updatedCtx), userTargetSelectors)+  where+    verbosity = cfgVerbosity normal flags++-- 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.+isMultiReplEnabled :: Flag Bool -> ProjectBaseContext -> Bool+isMultiReplEnabled replUseMulti ctx =+  fromFlagOrDefault False $+    projectConfigMultiRepl (projectConfigShared $ projectConfig ctx)+      <> replUseMulti++-- | Bring up a REPL with the targets.  With resolved user selectors and+-- context, adjust the REPL behaviour for the target.+targetedRepl :: NixStyleFlags ReplFlags -> TargetsAction ResolvedTargets ()+targetedRepl+  flags@NixStyleFlags{extraFlags = replFlags@ReplFlags{..}, configFlags}+  targetCtx+  ctx+  ((baseCtx, multiReplEnabled), targetSelectors) = do+    let withReplEnabled =           isJust $ flagToMaybe $ replWithRepl configureReplOptions          addConstraintWhen cond constraint base_ctx =@@ -381,7 +441,7 @@         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+        withInstallPlan (modifyVerbosityFlags 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 @@ -389,7 +449,7 @@             (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+            pkgId = maybe (error $ "cannot find " ++ prettyShow unitId) packageId (InstallPlan.lookup elaboratedPlan unitId)             baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx'            return (Just oci, baseCtx'')@@ -411,10 +471,15 @@          let           elaboratedPlan' =-            pruneInstallPlanToTargets-              TargetActionRepl-              targets-              elaboratedPlan+            -- Guard against pruning with empty targets and failing an assertion+            -- within pruneInstallPlanToTargets.+            if null targets+              then elaboratedPlan+              else+                pruneInstallPlanToTargets+                  TargetActionRepl+                  targets+                  elaboratedPlan           includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)          pkgsBuildStatus <-@@ -450,14 +515,14 @@     -- Multi Repl implementation 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 distDir "multi-out" $ \dir' -> do+      then withTempDirectoryEx tempFileOptions 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'+          _ -> usingGhciScript projectRoot replOpts'          let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''         printPlan verbosity baseCtx'' buildCtx'@@ -486,7 +551,7 @@         -- 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 <- (filter (/= "paths")) <$> listDirectory dir+        unit_files <- filter (/= "paths") <$> listDirectory dir          -- Order the unit files so that the find target becomes the active unit         let active_unit_fp :: Maybe FilePath@@ -504,8 +569,7 @@             unit_files_ordered :: [FilePath]             unit_files_ordered =               let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files-               in -- older GHC versions consider the last unit passed to be the active one.-                  -- GHC 9.14 no longer has the notion of "active" units.+               in -- GHC considers the last unit passed to be the active one                   other_units ++ active_unit_files              convertParStrat :: ParStratX Int -> ParStratX String@@ -527,27 +591,37 @@         -- single target repl         replOpts'' <- case targetCtx of           ProjectContext -> return replOpts'-          _ -> usingGhciScript compiler projectRoot replOpts'+          _ -> usingGhciScript 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-      where-        go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s)-        go m _ = m+    where+      projectRoot = distProjectRootDirectory $ distDirLayout ctx+      distDir = distDirectory $ distDirLayout ctx -    withCtx ctxVerbosity strings =-      withContextAndSelectors ctxVerbosity AcceptNoTargets (Just LibKind) flags strings globalFlags ReplCommand+      combine_search_paths paths =+        foldl' go Map.empty paths+        where+          go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s)+          go m _ = m -    verbosity = cfgVerbosity normal flags-    tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags+      verbosity = cfgVerbosity normal flags+      tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags+      validatedTargets' = validatedTargets verbosity replFlags -    validatedTargets' = validatedTargets verbosity replFlags+withCtx :: NixStyleFlags a -> [String] -> GlobalFlags -> TargetsAction [TargetSelector] b -> IO b+withCtx flags targetStrings globalFlags =+  withContextAndSelectors+    (cfgVerbosity normal flags)+    (if null targetStrings then AcceptNoTargets else RejectNoTargets)+    (Just LibKind)+    flags+    targetStrings+    globalFlags+    ReplCommand  -- | Create a constraint which requires a later version of Cabal. -- This is used for commands which require a specific feature from the Cabal library@@ -687,20 +761,13 @@ -- so we need to tell ghci to change back to the correct directory. -- -- The @-ghci-script@ flag is path to the ghci script responsible for changing to the--- correct directory. Only works on GHC >= 7.6, though. 🙁-usingGhciScript :: Compiler -> FilePath -> ReplOptions -> IO ReplOptions-usingGhciScript compiler projectRoot replOpts-  | compilerCompatVersion GHC compiler >= Just minGhciScriptVersion = do-      let ghciScriptPath = projectRoot </> "setcwd.ghci"-      cwd <- getCurrentDirectory-      writeFile ghciScriptPath (":cd " ++ cwd)-      return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :)-  | otherwise = return replOpts---- | First version of GHC where GHCi supported the flag we need.--- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html-minGhciScriptVersion :: Version-minGhciScriptVersion = mkVersion [7, 6]+-- correct directory.+usingGhciScript :: FilePath -> ReplOptions -> IO ReplOptions+usingGhciScript projectRoot replOpts = do+  let ghciScriptPath = projectRoot </> "setcwd.ghci"+  cwd <- getCurrentDirectory+  writeFile ghciScriptPath (":cd " ++ cwd)+  return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :)  -- | This defines what a 'TargetSelector' means for the @repl@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
src/Distribution/Client/CmdRun.hs view
@@ -19,7 +19,6 @@ import Distribution.Client.Compat.Prelude hiding (toList) import Prelude () -import Data.List (group) import qualified Data.Set as Set import Distribution.Client.CmdErrorMessages   ( plural@@ -62,7 +61,6 @@   , dataDirsEnvironmentForPlan   , elabExeDependencyPaths   )- import Distribution.Client.ScriptUtils   ( AcceptNoTargets (..)   , TargetContext (..)@@ -103,7 +101,7 @@   ( dieWithException   , info   , notice-  , safeHead+  , sortNub   , warn   , wrapText   )@@ -201,7 +199,9 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-runAction flags targetAndArgs globalFlags =+runAction flags targetAndArgs globalFlags = do+  fullArgs <- getFullArgs+  let (targetStr, args) = splitTargetAndArgs fullArgs targetAndArgs   withContextAndSelectors (cfgVerbosity normal flags) RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do     (baseCtx, defaultVerbosity) <- case targetCtx of       ProjectContext -> return (ctx, normal)@@ -215,7 +215,6 @@         when (buildSettingOnlyDeps (buildSettings baseCtx)) $           dieWithException verbosity NoSupportForRunCommand -        fullArgs <- getFullArgs         when (occursOnlyOrBefore fullArgs "+RTS" "--") $           warn verbosity $             giveRTSWarning "run"@@ -350,14 +349,68 @@             { progInvokePath = exePath             , progInvokeArgs = args             , progInvokeEnv =-                ("PATH", Just $ progPath)+                ("PATH", Just progPath)                   : dataDirsEnvironmentForPlan                     (distDirLayout baseCtx)                     elaboratedPlan             }-  where-    (targetStr, args) = splitAt 1 targetAndArgs +-- | Split @cabal run@ arguments (@exe cmd@ arguments in the examples) into+-- target selectors and target executable arguments.+--+-- When a target is given it appears in both lists:+--+-- >>> splitTargetAndArgs ["exe", "cmd", "target"] ["target"]+-- (["target"],[])+--+-- The @+RTS@ argument is passed to the executable so only appears in the first+-- list:+--+-- >>> splitTargetAndArgs ["exe", "cmd", "target", "+RTS"] ["target"]+-- (["target"],[])+--+-- The @--@ follows the @+RTS@ argument, so @+RTS@ is passed to the executable+-- and only appears in the first list:+--+-- >>> splitTargetAndArgs ["exe", "cmd", "target", "+RTS", "--"] ["target"]+-- (["target"],[])+--+-- The @--@ precedes the @+RTS@ argument, so @+RTS@ is included in the+-- 'targetAndArgs' list as well:+--+-- >>> splitTargetAndArgs ["exe", "cmd", "target", "--", "+RTS"] ["target", "+RTS"]+-- (["target"],["+RTS"])+--+-- Same examples as above but when no target is given:+--+-- >>> splitTargetAndArgs ["exe", "cmd"] []+-- ([],[])+-- >>> splitTargetAndArgs ["exe", "cmd", "+RTS"] []+-- ([],[])+-- >>> splitTargetAndArgs ["exe", "cmd", "+RTS", "--"] []+-- ([],[])+-- >>> splitTargetAndArgs ["exe", "cmd", "--", "+RTS"] ["+RTS"]+-- ([],["+RTS"])+splitTargetAndArgs+  :: [String]+  -- ^ Full command line arguments, the original command line from+  -- 'getFullArgs', which is only used to detect whether a @--@ separator was+  -- present so that @cabal run -- ...@ keeps the target empty.+  -> [String]+  -- ^ The second argument is the parser-produced list that combines targets and+  -- their arguments.  These arguments do not include those passed to @cabal@+  -- such as @+RTS@ preceding the @--@ separator.+  -> ([String], [String])+splitTargetAndArgs fullArgs targetAndArgs = case dropWhile (/= "--") fullArgs of+  ("--" : exeArgs) ->+    -- targetAndArgs contains targets (>=0) and args; exeArgs contains only args; so+    -- the difference (>=0) is the number of targets+    let numTargets = length targetAndArgs - length exeArgs+     in splitAt numTargets targetAndArgs+  _ ->+    -- No '--': first element (if any) is the target.+    splitAt 1 targetAndArgs+ -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was -- invoked as a script interpreter, i.e. via --@@ -400,16 +453,15 @@   -> ElaboratedInstallPlan   -> [ElaboratedConfiguredPackage] matchingPackagesByUnitId uid =-  catMaybes-    . fmap-      ( foldPlanPackage-          (const Nothing)-          ( \x ->-              if elabUnitId x == uid-                then Just x-                else Nothing-          )-      )+  mapMaybe+    ( foldPlanPackage+        (const Nothing)+        ( \x ->+            if elabUnitId x == uid+              then Just x+              else Nothing+        )+    )     . toList  -- | This defines what a 'TargetSelector' means for the @run@ command.@@ -557,14 +609,10 @@       ( (\(label, xs) -> "- " ++ label ++ ": " ++ renderListPretty xs)           <$> zip             ["executables", "test-suites", "benchmarks"]-            ( filter (not . null) . map removeDuplicates $-                map (componentNameRaw . availableTargetComponentName)-                  <$> (flip filterTargetsKind $ targets)-                  <$> [ExeKind, TestKind, BenchKind]+            ( filter (not . null) . map sortNub $+                (map (componentNameRaw . availableTargetComponentName) . (`filterTargetsKind` targets) <$> [ExeKind, TestKind, BenchKind])             )       )-  where-    removeDuplicates = catMaybes . map safeHead . group . sort renderRunProblem (TargetProblemMultipleTargets selectorMap) =   "The run command is for running a single executable at once. The targets "     ++ renderListCommaAnd
src/Distribution/Client/CmdSdist.hs view
@@ -114,6 +114,7 @@ import Distribution.Simple.Utils   ( dieWithException   , notice+  , ordNub   , withOutputMarker   , wrapText   )@@ -127,7 +128,11 @@   , unPackageName   ) import Distribution.Verbosity-  ( normal+  ( VerbosityFlags+  , defaultVerbosityHandles+  , mkVerbosity+  , normal+  , verbosityFlags   )  import qualified Data.ByteString.Lazy.Char8 as BSL@@ -169,7 +174,7 @@ -------------------------------------------------------------------------------  data SdistFlags = SdistFlags-  { sdistVerbosity :: Flag Verbosity+  { sdistVerbosity :: Flag VerbosityFlags   , sdistDistDir :: Flag (SymbolicPath Pkg (Dir Dist))   , sdistListSources :: Flag Bool   , sdistNulSeparated :: Flag Bool@@ -282,7 +287,9 @@               (outputPath pkg)               pkg   where-    verbosity = fromFlagOrDefault normal sdistVerbosity+    verbosity =+      mkVerbosity defaultVerbosityHandles $+        fromFlagOrDefault normal sdistVerbosity     listSources = fromFlagOrDefault False sdistListSources     nulSeparated = fromFlagOrDefault False sdistNulSeparated     mOutputPath = flagToMaybe sdistOutputPath@@ -334,7 +341,7 @@   let     -- Write String to stdout or file, using the default TextEncoding.     write str-      | outputFile == "-" = putStr (withOutputMarker verbosity str)+      | outputFile == "-" = putStr (withOutputMarker (verbosityFlags verbosity) str)       | otherwise = do           writeFile outputFile str           notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"@@ -358,7 +365,7 @@               gpd = srcpkgDescription pkg            files' <- listPackageSourcesWithDie verbosity dieWithException (Just $ makeSymbolicPath dir) (flattenPackageDescription gpd) knownSuffixHandlers-          let files = nub $ sort $ map (normalise . getSymbolicPath) files'+          let files = ordNub $ sort $ map (normalise . getSymbolicPath) files'           let prefix = makeRelative (normalise projectRootDir) dir           write $ concat [prefix </> i ++ [nulSep] | i <- files]         TarGzArchive -> do
src/Distribution/Client/CmdTarget.hs view
@@ -42,7 +42,9 @@   , wrapText   ) import Distribution.Verbosity-  ( normal+  ( defaultVerbosityHandles+  , mkVerbosity+  , normal   ) import Text.PrettyPrint import qualified Text.PrettyPrint as Pretty@@ -65,7 +67,7 @@             , caution             , unique             ]-    , commandNotes = Just $ \pname -> render $ examples pname+    , commandNotes = Just $ \pname -> render (examples pname) ++ "\n"     , commandDefaultFlags = defaultNixStyleFlags ()     , commandOptions = nixStyleOptions (const [])     }@@ -181,7 +183,9 @@    printTargetForms verbosity targetStrings targets elaboratedPlan   where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    verbosity =+      mkVerbosity defaultVerbosityHandles $+        fromFlagOrDefault normal (configVerbosity configFlags)     targetStrings = if null ts then ["all"] else ts     cliConfig =       commandLineFlagsToProjectConfig
src/Distribution/Client/CmdTest.hs view
@@ -212,8 +212,7 @@   -> Either TestTargetProblem k selectComponentTarget subtarget@WholeComponent t   | CTestName _ <- availableTargetComponentName t =-      either Left return $-        selectComponentTargetBasic subtarget t+      selectComponentTargetBasic subtarget t   | otherwise =       Left         ( notTestProblem
src/Distribution/Client/CmdUpdate.hs view
@@ -12,9 +12,6 @@ import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Compat.Directory-  ( setModificationTime-  ) import Distribution.Client.FetchUtils   ( downloadIndex   )@@ -55,8 +52,6 @@ import Distribution.Client.Setup   ( GlobalFlags   , RepoContext (..)-  , UpdateFlags-  , defaultUpdateFlags   ) import Distribution.Client.Types   ( RemoteRepo (..)@@ -75,8 +70,12 @@   ) import Distribution.Verbosity   ( lessVerbose+  , modifyVerbosityFlags   , normal   )+import System.Directory+  ( setModificationTime+  )  import qualified Data.Maybe as Unsafe (fromJust) import qualified Distribution.Compat.CharParsing as P@@ -102,8 +101,7 @@     , commandSynopsis = "Updates list of known packages."     , commandUsage = usageAlternatives "v2-update" ["[FLAGS] [REPOS]"]     , commandDescription = Just $ \_ ->-        wrapText $-          "For all known remote repositories, download the package list."+        wrapText "For all known remote repositories, download the package list."     , commandNotes = Just $ \pname ->         "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"           ++ "the same format and syntax that is supported by the --index-state flag.\n\n"@@ -179,7 +177,7 @@       unless (null updateRepoRequests) $ do         let remoteRepoNames = map repoName repos             unknownRepos =-              [ r | (UpdateRequest r _) <- updateRepoRequests, not (r `elem` remoteRepoNames)+              [ r | (UpdateRequest r _) <- updateRepoRequests, r `notElem` remoteRepoNames               ]         unless (null unknownRepos) $           dieWithException verbosity $@@ -212,7 +210,7 @@       unless (null reposToUpdate) $ do         jobCtrl <- newParallelJobControl (length reposToUpdate)         traverse_-          (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)+          (spawnJob jobCtrl . updateRepo verbosity repoCtxt)           reposToUpdate         traverse_ (\_ -> collectJob jobCtrl) reposToUpdate   where@@ -220,19 +218,14 @@     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -updateRepo-  :: Verbosity-  -> UpdateFlags-  -> RepoContext-  -> (Repo, RepoIndexState)-  -> IO ()-updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do-  transport <- repoContextGetTransport repoCtxt+updateRepo :: Verbosity -> RepoContext -> (Repo, RepoIndexState) -> IO ()+updateRepo verbosity repoCtxt (repo, indexState) = do   case repo of     RepoLocalNoIndex{} -> do       let index = RepoIndex repoCtxt repo       updatePackageIndexCacheFile verbosity index     RepoRemote{..} -> do+      transport <- repoContextGetTransport repoCtxt       downloadResult <-         downloadIndex           transport@@ -250,7 +243,7 @@     RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do       let index = RepoIndex repoCtxt repo       -- NB: This may be a NoTimestamp if we've never updated before-      current_ts <- currentIndexTimestamp (lessVerbose verbosity) index+      current_ts <- currentIndexTimestamp (modifyVerbosityFlags lessVerbose verbosity) index       -- NB: always update the timestamp, even if we didn't actually       -- download anything       writeIndexTimestamp index indexState@@ -282,7 +275,7 @@       -- This resolves indexState (which could be HEAD) into a timestamp       -- This could be null but should not be, since the above guarantees       -- we have an updated index.-      new_ts <- currentIndexTimestamp (lessVerbose verbosity) index+      new_ts <- currentIndexTimestamp (modifyVerbosityFlags lessVerbose verbosity) index        noticeNoWrap verbosity $         "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "."
− src/Distribution/Client/Compat/Directory.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}--module Distribution.Client.Compat.Directory-  ( setModificationTime-  , createFileLink-  , pathIsSymbolicLink-  , getSymbolicLinkTarget-  ) where--#if MIN_VERSION_directory(1,2,3)-import System.Directory (setModificationTime)-#else-import Data.Time.Clock (UTCTime)-#endif--#if MIN_VERSION_directory(1,3,1)-import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)-#elif defined(MIN_VERSION_unix)-import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink)-#endif------------------------------------------------------------------------------------ setModificationTime----------------------------------------------------------------------------------#if !MIN_VERSION_directory(1,2,3)--setModificationTime :: FilePath -> UTCTime -> IO ()-setModificationTime _fp _t = return ()--#endif------------------------------------------------------------------------------------ Symlink----------------------------------------------------------------------------------#if MIN_VERSION_directory(1,3,1)-#elif defined(MIN_VERSION_unix)-createFileLink :: FilePath -> FilePath -> IO ()-createFileLink = createSymbolicLink--pathIsSymbolicLink :: FilePath -> IO Bool-pathIsSymbolicLink fp = do-    status <- getSymbolicLinkStatus fp-    return (isSymbolicLink status)--getSymbolicLinkTarget :: FilePath -> IO FilePath-getSymbolicLinkTarget = readSymbolicLink--#else-createFileLink :: FilePath -> FilePath -> IO ()-createFileLink _ _ = fail "Symlinking feature not available"--pathIsSymbolicLink :: FilePath -> IO Bool-pathIsSymbolicLink _ = fail "Symlinking feature not available"--getSymbolicLinkTarget :: FilePath -> IO FilePath-getSymbolicLinkTarget _ = fail "Symlinking feature not available"-#endif
− src/Distribution/Client/Compat/ExecutablePath.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}---- Copied verbatim from base-4.6.0.0. We can't simply import--- System.Environment.getExecutablePath because we need compatibility with older--- GHCs.--module Distribution.Client.Compat.ExecutablePath (getExecutablePath) where--import Prelude---- The imports are purposely kept completely disjoint to prevent edits--- to one OS implementation from breaking another.--#if defined(darwin_HOST_OS)-import Data.Word-import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Ptr-import Foreign.Storable-import System.Posix.Internals-#elif defined(linux_HOST_OS)-import Foreign.C-import Foreign.Marshal.Array-import System.Posix.Internals-#elif defined(mingw32_HOST_OS)-import Data.Word-import Foreign.C-import Foreign.Marshal.Array-import Foreign.Ptr-import System.Posix.Internals-#else-import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Ptr-import Foreign.Storable-import System.Posix.Internals-#endif---- The exported function is defined outside any if-guard to make sure--- every OS implements it with the same type.---- | Returns the absolute pathname of the current executable.------ Note that for scripts and interactive sessions, this is the path to--- the interpreter (e.g. ghci.)------ /Since: 4.6.0.0/-getExecutablePath :: IO FilePath------------------------------------------------------------------------------------- Mac OS X--#if defined(darwin_HOST_OS)--type UInt32 = Word32--foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"-    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt---- | Returns the path of the main executable. The path may be a--- symbolic link and not the real file.------ See dyld(3)-_NSGetExecutablePath :: IO FilePath-_NSGetExecutablePath =-    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X-    alloca $ \ bufsize -> do-        poke bufsize 1024-        status <- c__NSGetExecutablePath buf bufsize-        if status == 0-            then peekFilePath buf-            else do reqBufsize <- fromIntegral `fmap` peek bufsize-                    allocaBytes reqBufsize $ \ newBuf -> do-                        status2 <- c__NSGetExecutablePath newBuf bufsize-                        if status2 == 0-                             then peekFilePath newBuf-                             else error "_NSGetExecutablePath: buffer too small"--foreign import ccall unsafe "stdlib.h realpath"-    c_realpath :: CString -> CString -> IO CString---- | Resolves all symbolic links, extra \/ characters, and references--- to \/.\/ and \/..\/. Returns an absolute pathname.------ See realpath(3)-realpath :: FilePath -> IO FilePath-realpath path =-    withFilePath path $ \ fileName ->-    allocaBytes 1024 $ \ resolvedName -> do-        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName-        peekFilePath resolvedName--getExecutablePath = _NSGetExecutablePath >>= realpath------------------------------------------------------------------------------------- Linux--#elif defined(linux_HOST_OS)--foreign import ccall unsafe "readlink"-    c_readlink :: CString -> CString -> CSize -> IO CInt---- | Reads the @FilePath@ pointed to by the symbolic link and returns--- it.------ See readlink(2)-readSymbolicLink :: FilePath -> IO FilePath-readSymbolicLink file =-    allocaArray0 4096 $ \buf -> do-        withFilePath file $ \s -> do-            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $-                   c_readlink s buf 4096-            peekFilePathLen (buf,fromIntegral len)--getExecutablePath = readSymbolicLink $ "/proc/self/exe"------------------------------------------------------------------------------------- Windows--{- FOURMOLU_DISABLE -}-#elif defined(mingw32_HOST_OS)--# if defined(i386_HOST_ARCH)-#  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)-#  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif--foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"-    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32--getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32-  where-    go size = allocaArray (fromIntegral size) $ \ buf -> do-        ret <- c_GetModuleFileName nullPtr buf size-        case ret of-            0 -> error "getExecutablePath: GetModuleFileNameW returned an error"-            _ | ret < size -> peekFilePath buf-              | otherwise  -> go (size * 2)------------------------------------------------------------------------------------- Fallback to argv[0]--#else--foreign import ccall unsafe "getFullProgArgv"-    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()--getExecutablePath =-    alloca $ \ p_argc ->-    alloca $ \ p_argv -> do-        c_getFullProgArgv p_argc p_argv-        argc <- peek p_argc-        if argc > 0-            -- If argc > 0 then argv[0] is guaranteed by the standard-            -- to be a pointer to a null-terminated string.-            then peek p_argv >>= peek >>= peekFilePath-            else error $ "getExecutablePath: " ++ msg-  where msg = "no OS specific implementation and program name couldn't be " ++-              "found in argv"------------------------------------------------------------------------------------#endif-{- FOURMOLU_ENABLE -}
src/Distribution/Client/Config.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-}  -----------------------------------------------------------------------------@@ -114,6 +114,7 @@   )  import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M import Distribution.Client.Errors import Distribution.Client.HttpUtils@@ -208,11 +209,13 @@   , notice   , toUTF8BS   , warn+  , writeFileAtomic   ) import Distribution.Solver.Types.ConstraintSource import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath) import Distribution.Verbosity   ( normal+  , verbosityFlags   ) import Network.URI   ( URI (..)@@ -232,7 +235,6 @@ import System.FilePath   ( normalise   , takeDirectory-  , (<.>)   , (</>)   ) import System.IO.Error@@ -358,6 +360,7 @@       combinedSavedGlobalFlags =         GlobalFlags           { globalVersion = combine globalVersion+          , globalFullVersion = combine globalFullVersion           , globalNumericVersion = combine globalNumericVersion           , globalConfigFile = combine globalConfigFile           , globalConstraintsFile = combine globalConstraintsFile@@ -368,7 +371,6 @@           , globalLogsDir = combine globalLogsDir           , globalIgnoreExpiry = combine globalIgnoreExpiry           , globalHttpTransport = combine globalHttpTransport-          , globalNix = combine globalNix           , globalStoreDir = combine globalStoreDir           , globalProgPathExtra = lastNonEmptyNL globalProgPathExtra           }@@ -553,6 +555,7 @@               combine configAllowDependingOnPrivateLibs           , configCoverageFor = combine configCoverageFor           , configIgnoreBuildTools = combine configIgnoreBuildTools+          , configBytecodeLib = combine configBytecodeLib           }         where           combine = combine' savedConfigureFlags@@ -600,6 +603,7 @@           , uploadPassword = combine uploadPassword           , uploadPasswordCmd = combine uploadPasswordCmd           , uploadVerbosity = combine uploadVerbosity+          , uploadRepoName = combine uploadRepoName           }         where           combine = combine' savedUploadFlags@@ -610,6 +614,7 @@           , reportUsername = combine reportUsername           , reportPassword = combine reportPassword           , reportVerbosity = combine reportVerbosity+          , reportRepoName = combine reportRepoName           }         where           combine = combine' savedReportFlags@@ -675,6 +680,7 @@           { flagProjectDir = combine flagProjectDir           , flagProjectFile = combine flagProjectFile           , flagIgnoreProject = combine flagIgnoreProject+          , flagProjectFileParser = combine flagProjectFileParser           }         where           combine = combine' savedProjectFlags@@ -931,10 +937,10 @@     "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"   , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)     "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"-  , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)-    "be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"   , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)     "d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"+  , -- Tikhon Jelvis (06nM6r1kOYt49YE5e1+j8VKiiYUFjFQ6HrOpPZu+fDE=)+    "c7de58fc6a224b92b5b513f26fbb8b370f2d97c7cfe0075a951314a55734be93"   ]  -- | The required threshold of root key signatures for hackage.haskell.org@@ -952,7 +958,6 @@ -- use 'loadRawConfig'. loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadConfig verbosity configFileFlag = do-  warnOnTwoConfigs verbosity   config <- loadRawConfig verbosity configFileFlag   extendToEffectiveConfig config @@ -979,7 +984,7 @@ -- effective configuration. loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadRawConfig verbosity configFileFlag = do-  (source, configFile) <- getConfigFilePathAndSource configFileFlag+  (source, configFile) <- getConfigFilePathAndSource verbosity configFileFlag   minp <- readConfigFile mempty configFile   case minp of     Nothing -> do@@ -1022,17 +1027,28 @@  -- | Returns the config file path, without checking that the file exists. -- The order of precedence is: input flag, CABAL_CONFIG, default location.-getConfigFilePath :: Flag FilePath -> IO FilePath-getConfigFilePath = fmap snd . getConfigFilePathAndSource+getConfigFilePath :: Verbosity -> Flag FilePath -> IO FilePath+getConfigFilePath verbosity configFilePath = fmap snd $ getConfigFilePathAndSource verbosity configFilePath -getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)-getConfigFilePathAndSource configFileFlag =+getConfigFilePathAndSource :: Verbosity -> Flag FilePath -> IO (ConfigFileSource, FilePath)+getConfigFilePathAndSource verbosity configFileFlag =   getSource sources   where+    defaultSource = do+      cfg <- defaultConfigFile+      -- We only warn on two configs when the user has not explicitly indicated+      -- a preference (using any of CABAL_CONFIG, CABAL_DIR, or the --config+      -- option).+      dir <- lookupEnv "CABAL_DIR"+      case dir of+        Nothing -> warnOnTwoConfigs verbosity+        Just _ -> return ()+      return $ Just cfg+     sources =       [ (CommandlineOption, return . flagToMaybe $ configFileFlag)-      , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)-      , (Default, Just `liftM` defaultConfigFile)+      , (EnvironmentVariable, lookup "CABAL_CONFIG" <$> getEnvironment)+      , (Default, defaultSource)       ]      getSource [] = error "no config file path candidate found."@@ -1063,11 +1079,10 @@  writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do-  let tmpFile = file <.> "tmp"   createDirectoryIfMissing True (takeDirectory file)-  writeFile tmpFile $-    explanation ++ showConfigWithComments comments vals ++ "\n"-  renameFile tmpFile file+  writeFileAtomic file $+    LBS.fromStrict . toUTF8BS $+      explanation ++ showConfigWithComments comments vals ++ "\n"   where     explanation =       unlines@@ -1101,7 +1116,6 @@           { savedGlobalFlags =               defaultGlobalFlags                 { globalRemoteRepos = toNubList [defaultRemoteRepo]-                , globalNix = mempty                 }           , savedInitFlags =               mempty@@ -1189,7 +1203,7 @@           $ let name = "optimization"              in FieldDescr                   name-                  ( \f -> case f of+                  ( \case                       Flag NoOptimisation -> Disp.text "False"                       Flag NormalOptimisation -> Disp.text "True"                       Flag MaximumOptimisation -> Disp.text "2"@@ -1220,7 +1234,7 @@           let name = "debug-info"            in FieldDescr                 name-                ( \f -> case f of+                ( \case                     Flag NoDebugInfo -> Disp.text "False"                     Flag MinimalDebugInfo -> Disp.text "1"                     Flag NormalDebugInfo -> Disp.text "True"@@ -1782,9 +1796,16 @@         (fmap (field . savedConfigureFlags) mcomment)         ((field . savedConfigureFlags) vals) -    -- skip fields based on field name.  currently only skips "remote-repo",-    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)-    skipSomeFields = filter ((/= "remote-repo") . fieldName)+    -- Skip fields based on field name.+    skipSomeFields =+      filter+        ( ( `notElem`+              [ "remote-repo" -- rendered as a section (see 'ppRemoteRepoSection')+              , "builddir" -- no effect in config file (see Note [reading project configuration])+              ]+          )+            . fieldName+        )  -- | Fields for the 'install-dirs' sections. installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]@@ -1925,7 +1946,7 @@ -- config file and the one that cabal would generate if it didn't exist. userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] userConfigDiff verbosity globalFlags extraLines = do-  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)+  userConfig <- loadRawConfig (verbosity{verbosityFlags = normal}) (globalConfigFile globalFlags)   extraConfig <- parseExtraLines verbosity extraLines   testConfig <- initialSavedConfig   return $@@ -1979,11 +2000,11 @@ -- | Update the user's config file keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () userConfigUpdate verbosity globalFlags extraLines = do-  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)+  userConfig <- loadRawConfig (verbosity{verbosityFlags = normal}) (globalConfigFile globalFlags)   extraConfig <- parseExtraLines verbosity extraLines   newConfig <- initialSavedConfig   commentConf <- commentSavedConfig-  cabalFile <- getConfigFilePath $ globalConfigFile globalFlags+  cabalFile <- getConfigFilePath verbosity $ globalConfigFile globalFlags   let backup = cabalFile ++ ".backup"   notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."   renameFile cabalFile backup
src/Distribution/Client/Configure.hs view
@@ -42,7 +42,8 @@   , filterConfigureFlags   ) import Distribution.Client.SetupWrapper-  ( SetupScriptOptions (..)+  ( SetupRunnerArgs (NotInLibrary)+  , SetupScriptOptions (..)   , defaultSetupScriptOptions   , setupWrapper   )@@ -130,6 +131,7 @@   )  import Distribution.Client.Errors+import Distribution.Verbosity (verbosityFlags, verbosityLevel)  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags. Currently, it implements no@@ -203,6 +205,7 @@           configCommonFlags           (const (return configFlags))           (const extraArgs)+          NotInLibrary       Right installPlan0 ->         let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0          in case fst (InstallPlan.ready installPlan) of@@ -246,7 +249,6 @@               (flagToMaybe (configCabalVersion configExFlags))           )           Nothing-          False        logMsg message rest = debug verbosity message >> rest @@ -258,7 +260,6 @@   -> SymbolicPath Pkg (Dir Dist)   -> VersionRange   -> Maybe Lock-  -> Bool   -> InstalledPackageIndex   -> Maybe ReadyPackage   -> SetupScriptOptions@@ -270,7 +271,6 @@   distPref   cabalVersion   lock-  forceExternal   index   mpkg =     SetupScriptOptions@@ -288,7 +288,6 @@       , useExtraEnvOverrides = []       , setupCacheLock = lock       , useWin32CleanHack = False-      , forceExternalSetupMethod = forceExternal       , -- If we have explicit setup dependencies, list them; otherwise, we give         -- the empty list of dependencies; ideally, we would fix the version of         -- Cabal here, so that we no longer need the special case for that in@@ -462,7 +461,7 @@           -- package database and executables never show up in the           -- installed package index           . setSolveExecutables (SolveExecutables False)-          . setSolverVerbosity verbosity+          . setSolverVerbosity (verbosityLevel verbosity)           $ standardInstallPolicy             installedPkgIndex             -- NB: We pass in an *empty* source package database,@@ -506,6 +505,7 @@       configCommonFlags       (return . configureFlags)       (const extraArgs)+      NotInLibrary     where       gpkg :: PkgDesc.GenericPackageDescription       gpkg = srcpkgDescription spkg@@ -515,7 +515,7 @@           configFlags             { configCommonFlags =                 (configCommonFlags configFlags)-                  { setupVerbosity = toFlag verbosity+                  { setupVerbosity = toFlag $ verbosityFlags verbosity                   , setupWorkingDir = maybeToFlag $ useWorkingDir scriptOptions                   }             , configIPID =
src/Distribution/Client/Dependency.hs view
@@ -1,7 +1,5 @@ ----------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Dependency -- Copyright   :  (c) David Himmelstrup 2005,@@ -65,6 +63,7 @@   , addSetupCabalMinVersionConstraint   , addSetupCabalMaxVersionConstraint   , addSetupCabalProfiledDynamic+  , setImplicitSetupInfo   ) where  import Distribution.Client.Compat.Prelude@@ -123,6 +122,12 @@   , SolverConfig (..)   , modularResolver   )+import Distribution.Solver.Modular.Message+  ( renderSummarizedMessage+  )+import Distribution.Solver.Types.SummarizedMessage+  ( SummarizedMessage (..)+  ) import Distribution.System   ( Platform   )@@ -131,10 +136,11 @@   ( DependencySatisfaction (..)   ) import Distribution.Verbosity-  ( normal+  ( VerbosityLevel (..)   ) import Distribution.Version +import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource@@ -152,12 +158,15 @@ import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage+  ( SolverPackage (SolverPackage)+  ) import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Variable  import Control.Exception   ( assert   )+import Data.Foldable (fold) import Data.List   ( maximumBy   )@@ -202,7 +211,7 @@   -- so we shouldn't solve for them.  See #3875.   , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)   -- ^ Function to override the solver's goal-ordering heuristics.-  , depResolverVerbosity :: Verbosity+  , depResolverVerbosity :: VerbosityLevel   }  showDepResolverParams :: DepResolverParams -> String@@ -299,7 +308,7 @@     , depResolverEnableBackjumping = EnableBackjumping True     , depResolverSolveExecutables = SolveExecutables True     , depResolverGoalOrder = Nothing-    , depResolverVerbosity = normal+    , depResolverVerbosity = Normal     }  addTargets@@ -429,12 +438,30 @@     { depResolverGoalOrder = order     } -setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams+setSolverVerbosity :: VerbosityLevel -> DepResolverParams -> DepResolverParams setSolverVerbosity verbosity params =   params     { depResolverVerbosity = verbosity     } +dependOnWiredIns :: CompilerInfo -> DepResolverParams -> DepResolverParams+dependOnWiredIns compiler params = addConstraints extraConstraints params+  where+    extraConstraints =+      [ LabeledPackageConstraint+        (PackageConstraint (ScopeAnyQualifier pkgName) (PackagePropertyInstalledSpecificUnitId unitId))+        ConstraintSourceNonReinstallablePackage+      | (pkgName, unitId) <- fromMaybe [] $ compilerInfoWiredInUnitIds compiler+      ]+        +++        -- Old versions of `base` must be excluded from build plans still as they do not depend on any version of a wired-in unit.+        -- If we do not do this then we will get confusing error messages about old versions of `base` being unbuildable.+        -- Newer versions of `base` will be handled gracefully as they were designed to be reinstallable.+        [ LabeledPackageConstraint+            (PackageConstraint (ScopeAnyQualifier $ mkPackageName "base") (PackagePropertyVersion (orLaterVersion (mkVersion [4, 22]))))+            ConstraintSourceNonReinstallablePackage+        ]+ -- | Some packages are specific to a given compiler version and should never be -- reinstalled. dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams@@ -596,49 +623,96 @@ removeBound RelaxLower RelaxDepModCaret = transformCaretLower removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper --- | Supply defaults for packages without explicit Setup dependencies+-- | Supply defaults for packages without explicit Setup dependencies.+-- It also serves to add the implicit dependency on @hooks-exe@ needed to+-- compile the @Setup.hs@ executable produced from 'SetupHooks' when+-- @build-type: Hooks@. The first argument function determines which implicit+-- dependencies are needed (including the one on @hooks-exe@). -- -- Note: It's important to apply 'addDefaultSetupDepends' after -- 'addSourcePackages'. Otherwise, the packages inserted by -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. addDefaultSetupDependencies-  :: (UnresolvedSourcePackage -> Maybe [Dependency])+  :: (Maybe [Dependency] -> PD.BuildType -> Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo)+  -- ^ Function to update the SetupBuildInfo of the package using those dependencies+  -> (UnresolvedSourcePackage -> Maybe [Dependency])+  -- ^ Function to determine extra setup dependencies   -> DepResolverParams   -> DepResolverParams-addDefaultSetupDependencies defaultSetupDeps params =+addDefaultSetupDependencies applyDefaultSetupDeps defaultSetupDeps params =   params     { depResolverSourcePkgIndex =-        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)+        fmap go (depResolverSourcePkgIndex params)     }   where-    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage-    applyDefaultSetupDeps srcpkg =+    go :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    go srcpkg =       srcpkg         { srcpkgDescription =             gpkgdesc               { PD.packageDescription =                   pkgdesc                     { PD.setupBuildInfo =-                        case PD.setupBuildInfo pkgdesc of-                          Just sbi -> Just sbi-                          Nothing -> case defaultSetupDeps srcpkg of-                            Nothing -> Nothing-                            Just deps-                              | isCustom ->-                                  Just-                                    PD.SetupBuildInfo-                                      { PD.defaultSetupDepends = True-                                      , PD.setupDepends = deps-                                      }-                              | otherwise -> Nothing+                        addCabalDepForHooks (PD.buildType pkgdesc) $+                          applyDefaultSetupDeps+                            (defaultSetupDeps srcpkg)+                            (PD.buildType pkgdesc)+                            (PD.setupBuildInfo pkgdesc)                     }               }         }       where-        isCustom = PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks         gpkgdesc = srcpkgDescription srcpkg         pkgdesc = PD.packageDescription gpkgdesc +-- | Add an implicit dependency on @Cabal@ for a @build-type: Hooks@ package+-- that doesn't explicitly depend on @Cabal@. Rationale: we need the @Cabal@+-- library in order to compile @main = defaultMainWithSetupHooks setupHooks@.+--+-- This ensures the solver picks a consistent version of @Cabal@ when other+-- packages in the @setup-depends@ stanza depend on @Cabal@.+-- See https://github.com/haskell/cabal/issues/11331.+--+-- NB: don't do this for @build-type: Custom@, as it is possible for such+-- packages to not depend on @Cabal@ at all (although basically unheard of+-- in practice).+addCabalDepForHooks :: PD.BuildType -> Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo+addCabalDepForHooks PD.Hooks = fmap addDep+  where+    addDep sbi@(PD.SetupBuildInfo{PD.setupDepends = deps})+      | any ((== cabalPkgName) . depPkgName) deps =+          sbi+      | otherwise =+          sbi{PD.setupDepends = Dependency cabalPkgName anyVersion mainLibSet : deps}+    cabalPkgName = mkPackageName "Cabal"+addCabalDepForHooks _ = id++-- | Provides the fallback default "setup-depends", when:+--+--  1. There is no 'SetupBuildInfo' to start with,+--  2. The passed-in optional default dependencies are not @Nothing@.+setImplicitSetupInfo+  :: Maybe [Dependency]+  -- ^ optional default dependencies+  -> PD.BuildType+  -> Maybe PD.SetupBuildInfo+  -> Maybe PD.SetupBuildInfo+setImplicitSetupInfo mdeps buildty msetupinfo =+  case msetupinfo of+    Just sbi -> Just sbi+    Nothing -> case mdeps of+      Nothing -> Nothing+      Just deps+        | hasSetupStanza ->+            Just+              PD.SetupBuildInfo+                { PD.defaultSetupDepends = True+                , PD.setupDepends = deps+                }+        | otherwise -> Nothing+  where+    hasSetupStanza = buildty == PD.Custom || buildty == PD.Hooks+ -- | If a package has a custom setup then we need to add a setup-depends -- on Cabal. addSetupCabalMinVersionConstraint@@ -734,7 +808,7 @@   -> [PackageSpecifier UnresolvedSourcePackage]   -> DepResolverParams standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers =-  addDefaultSetupDependencies mkDefaultSetupDeps $+  addDefaultSetupDependencies setImplicitSetupInfo mkDefaultSetupDeps $     basicInstallPolicy       installedPkgIndex       sourcePkgDb@@ -787,9 +861,10 @@   -> Maybe PkgConfigDb   -> DepResolverParams   -> Progress String String SolverInstallPlan-resolveDependencies platform comp pkgConfigDB params =-  Step (showDepResolverParams finalparams) $-    fmap (validateSolverResult platform comp indGoals) $+resolveDependencies platform comp pkgConfigDB params = do+  step (showDepResolverParams finalparams)+  pkgs <-+    formatProgress $       runSolver         ( SolverConfig             reordGoals@@ -816,6 +891,7 @@         preferences         constraints         targets+  validateSolverResult platform comp indGoals pkgs   where     finalparams@( DepResolverParams                     targets@@ -840,10 +916,13 @@                     order                     verbosity                   ) =-        if asBool (depResolverAllowBootLibInstalls params)-          then params+        if isJust (compilerInfoWiredInUnitIds comp) || asBool (depResolverAllowBootLibInstalls params)+          then dependOnWiredIns comp params           else dontInstallNonReinstallablePackages params +    formatProgress :: Progress SummarizedMessage String a -> Progress String String a+    formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p+     preferences :: PackageName -> PackagePreferences     preferences = interpretPackagesPreference targets defpref prefs @@ -863,7 +942,7 @@   where     versionPref :: PackageName -> [VersionRange]     versionPref pkgname =-      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)+      Map.findWithDefault [anyVersion] pkgname versionPrefs     versionPrefs =       Map.fromListWith         (++)@@ -873,7 +952,7 @@      installPref :: PackageName -> InstalledPreference     installPref pkgname =-      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)+      Map.findWithDefault (installPrefDefault pkgname) pkgname installPrefs     installPrefs =       Map.fromList         [ (pkgname, pref)@@ -892,10 +971,10 @@      stanzasPref :: PackageName -> [OptionalStanza]     stanzasPref pkgname =-      fromMaybe [] (Map.lookup pkgname stanzasPrefs)+      Map.findWithDefault [] pkgname stanzasPrefs     stanzasPrefs =       Map.fromListWith-        (\a b -> nub (a ++ b))+        (\a b -> ordNub (a ++ b))         [ (pkgname, pref)         | PackageStanzasPreference pkgname pref <- prefs         ]@@ -913,13 +992,13 @@   -> CompilerInfo   -> IndependentGoals   -> [ResolverPackage UnresolvedPkgLoc]-  -> SolverInstallPlan+  -> Progress String String SolverInstallPlan validateSolverResult platform comp indepGoals pkgs =   case planPackagesProblems platform comp pkgs of     [] -> case SolverInstallPlan.new indepGoals graph of-      Right plan -> plan-      Left problems -> error (formatPlanProblems problems)-    problems -> error (formatPkgProblems problems)+      Right plan -> return plan+      Left problems -> fail (formatPlanProblems problems)+    problems -> fail (formatPkgProblems problems)   where     graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)     graph = Graph.fromDistinctList pkgs@@ -971,7 +1050,7 @@   , not (null packageProblems)   ]     ++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups-       | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs+       | dups <- fmap toList $ duplicatesBy (comparing Graph.nodeKey) pkgs        , aDup <- case dups of           [] -> []           (ad : _) -> [ad]@@ -1033,7 +1112,7 @@          | pkgs <-             CD.nonSetupDeps               ( fmap-                  (duplicatesBy (comparing packageName))+                  (fmap toList . duplicatesBy (comparing packageName))                   specifiedDeps1               )          ]@@ -1050,9 +1129,6 @@       specifiedDeps1 :: ComponentDeps [PackageId]       specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 -      specifiedDeps :: [PackageId]-      specifiedDeps = CD.flatDeps specifiedDeps1-       mergedFlags :: [MergeResult PD.FlagName PD.FlagName]       mergedFlags =         mergeBy@@ -1069,7 +1145,7 @@       dependencyName (Dependency name _ _) = name        mergedDeps :: [MergeResult Dependency PackageId]-      mergedDeps = mergeDeps requiredDeps specifiedDeps+      mergedDeps = mergeDeps requiredDeps (fold specifiedDeps1)        mergeDeps         :: [Dependency]
src/Distribution/Client/Dependency/Types.hs view
@@ -24,6 +24,8 @@ instance Binary PreSolver instance Binary Solver +instance NFData PreSolver+ instance Structured PreSolver instance Structured Solver
src/Distribution/Client/DistDirLayout.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}  -- |@@ -8,6 +9,7 @@   ( -- * 'DistDirLayout'     DistDirLayout (..)   , DistDirParams (..)+  , ProjectFileKey (..)   , defaultDistDirLayout      -- * 'ProjectRoot'@@ -70,16 +72,32 @@   --  Optimization   } +-- | The principal project file is read and parsed. Its file name was either+-- provided with the @--project-file@ option, or it had the default name of+-- @cabal.project@.+--+-- Related ``.local`` and ``.freeze`` files are read and parsed separately.+--+-- This key datatype distinguishes between the different project files, so that+-- we can give better error messages, such as encountering an unexpected+-- extension to the principal project file or when a ``.local`` or ``.freeze``+-- is itself passed as the principal project file or when either are explicitly+-- imported. They should only ever be implicitly imported.+data ProjectFileKey+  = ProjectFileKeyMain+  | ProjectFileKeyLocal+  | ProjectFileKeyFreeze+  deriving (Eq, Ord, Show)+ -- | The layout of the project state directory. Traditionally this has been -- called the @dist@ directory. data DistDirLayout = DistDirLayout   { distProjectRootDirectory :: FilePath   -- ^ The root directory of the project. Many other files are relative to   -- this location (e.g. the @cabal.project@ file).-  , distProjectFile :: String -> FilePath-  -- ^ The @cabal.project@ file and related like @cabal.project.freeze@.-  -- The parameter is for the extension, like \"freeze\", or \"\" for the-  -- main file.+  , distProjectFile :: ProjectFileKey -> FilePath+  -- ^ Files that are project parsing roots, the main @cabal.project@ file and+  -- its related freeze file and local file.   , distDirectory :: FilePath   -- ^ The \"dist\" directory, which is the root of where cabal keeps all   -- its state including the build artifacts from each package we build.@@ -183,8 +201,11 @@     distProjectRootDirectory :: FilePath     distProjectRootDirectory = projectRootDir -    distProjectFile :: String -> FilePath-    distProjectFile ext = projectFile <.> ext+    distProjectFile :: ProjectFileKey -> FilePath+    distProjectFile = \case+      ProjectFileKeyMain -> projectFile+      ProjectFileKeyLocal -> projectFile <.> "local"+      ProjectFileKeyFreeze -> projectFile <.> "freeze"      distDirectory :: FilePath     distDirectory =@@ -289,7 +310,7 @@      storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD     storePackageDBStack compiler extraPackageDB =-      (interpretPackageDbFlags False extraPackageDB)+      interpretPackageDbFlags False extraPackageDB         ++ [storePackageDB compiler]      storeIncomingDirectory :: Compiler -> FilePath
src/Distribution/Client/Errors.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  ----------------------------------------------------------------------------- @@ -37,6 +36,8 @@ import qualified Text.PrettyPrint as PP import Text.Regex.Posix.ByteString (WrapError) +import Distribution.Client.Errors.Parser+ data CabalInstallException   = UnpackGet   | NotTarballDir FilePath@@ -61,7 +62,7 @@   | UnableToPerformInplaceUpdate   | EmptyValuePagerEnvVariable   | FileDoesntExist FilePath-  | ParseError+  | CabalCheckParseError CabalFileParseError   | CabalFileNotFound FilePath   | FindOpenProgramLocationErr String   | PkgConfParseFailed String@@ -119,7 +120,7 @@   | BenchActionException   | RenderBenchTargetProblem [String]   | ReportUserTargetProblems [String]-  | ReportUserTargerNonexistantFile [String]+  | ReportUserTargetNonexistentFile [String]   | ReportUserTargetUnexpectedFile [String]   | ReportUserTargetUnexpectedUriScheme [String]   | ReportUserTargetUnrecognisedUri [String]@@ -187,6 +188,10 @@   | CmdPathAcceptsNoTargets   | CmdPathCommandDoesn'tSupportDryRun   | GenBoundsDoesNotSupportScript FilePath+  | LegacyAndParsecParseResultsDiffer FilePath String String+  | CabalFileParseFailure CabalFileParseError+  | ProjectConfigParseFailure ProjectConfigParseError+  | ProjectConfigNoPackages FilePath   deriving (Show)  exceptionCodeCabalInstall :: CabalInstallException -> Int@@ -214,7 +219,7 @@   UnableToPerformInplaceUpdate{} -> 7032   EmptyValuePagerEnvVariable{} -> 7033   FileDoesntExist{} -> 7034-  ParseError{} -> 7035+  CabalCheckParseError{} -> 7035   CabalFileNotFound{} -> 7036   FindOpenProgramLocationErr{} -> 7037   PkgConfParseFailed{} -> 7038@@ -272,7 +277,7 @@   BenchActionException{} -> 7092   RenderBenchTargetProblem{} -> 7093   ReportUserTargetProblems{} -> 7094-  ReportUserTargerNonexistantFile{} -> 7095+  ReportUserTargetNonexistentFile{} -> 7095   ReportUserTargetUnexpectedFile{} -> 7096   ReportUserTargetUnexpectedUriScheme{} -> 7097   ReportUserTargetUnrecognisedUri{} -> 7098@@ -340,6 +345,10 @@   CmdPathAcceptsNoTargets{} -> 7161   CmdPathCommandDoesn'tSupportDryRun -> 7163   GenBoundsDoesNotSupportScript{} -> 7164+  LegacyAndParsecParseResultsDiffer{} -> 7165+  CabalFileParseFailure{} -> 7166+  ProjectConfigParseFailure{} -> 7167+  ProjectConfigNoPackages{} -> 7168  exceptionMessageCabalInstall :: CabalInstallException -> String exceptionMessageCabalInstall e = case e of@@ -378,7 +387,7 @@   UnableToPerformInplaceUpdate -> "local project file has conditional and/or import logic, unable to perform and automatic in-place update"   EmptyValuePagerEnvVariable -> "man: empty value of the PAGER environment variable"   FileDoesntExist fpath -> "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."-  ParseError -> "parse error"+  CabalCheckParseError err -> renderCabalFileParseError err   CabalFileNotFound cabalFile -> "Package .cabal file not found in the tarball: " ++ cabalFile   FindOpenProgramLocationErr err -> err   PkgConfParseFailed perror ->@@ -405,7 +414,7 @@       ++ msg       ++ "The package index or index cache is probably "       ++ "corrupt. Running cabal update might fix it."-  ReadIndexCache paths -> show (paths)+  ReadIndexCache paths -> show paths   ConfigStateFileException err -> err   UploadAction -> "the 'upload' command expects at least one .tar.gz archive."   UploadActionDocumentation ->@@ -520,7 +529,7 @@       ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"       ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"       ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"-  ReportUserTargerNonexistantFile target ->+  ReportUserTargetNonexistentFile target ->     unlines       [ "The file does not exist '" ++ name ++ "'."       | name <- target@@ -703,21 +712,18 @@                   ]           ]       | (target, nosuch) <- targets-      , let groupByContainer =-              map-                ( \g@((inside, _, _, _) : _) ->-                    ( inside-                    , [ (thing, got, alts)-                      | (_, thing, got, alts) <- g-                      ]-                    )-                )-                . groupBy ((==) `on` (\(x, _, _, _) -> x))-                . sortBy (compare `on` (\(x, _, _, _) -> x))       ]     where       mungeThing "file" = "file target"       mungeThing thing = thing+      groupByContainer xs =+        [ ( inside+          , [ (thing, got, alts)+            | (_, thing, got, alts) <- g+            ]+          )+        | g@((inside, _, _, _) : _) <- groupBy ((==) `on` (\(x, _, _, _) -> x)) $ sortBy (compare `on` (\(x, _, _, _) -> x)) xs+        ]   TargetSelectorAmbiguousErr targets ->     unlines       [ "Ambiguous target '"@@ -827,7 +833,7 @@     "--enable-benchmarks was specified, but benchmarks can't "       ++ "be enabled in a remote package"   UnknownPackage hn name ->-    concat $+    concat       [ "Unknown package \""       , hn       , "\". "@@ -864,6 +870,26 @@     "The 'path' command doesn't support the flag '--dry-run'."   GenBoundsDoesNotSupportScript{} ->     "The 'gen-bounds' command does not support script targets."+  LegacyAndParsecParseResultsDiffer _fp legacyParsec parsec ->+    unlines+      [ "The legacy and parsec parsers produced different results for the project file. This is unexpected, please report this as a bug."+      , "The legacy parser will be removed in the next major version."+      , "Legacy parse result:"+      , legacyParsec+      , "Parsec parse result:"+      , parsec+      ]+  CabalFileParseFailure cbfError ->+    renderCabalFileParseError cbfError+  ProjectConfigParseFailure pcfError ->+    renderProjectConfigParseError pcfError+  ProjectConfigNoPackages configPath ->+    concat+      [ "The project config '"+      , configPath+      , "' requires at least one of the fields 'packages' "+      , "or 'optional-packages', but neither was specified."+      ]  instance Exception (VerboseException CabalInstallException) where   displayException :: VerboseException CabalInstallException -> [Char]
+ src/Distribution/Client/Errors/Parser.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Client.Errors.Parser where++import Distribution.Client.Compat.Prelude+import System.FilePath (normalise)+import Prelude ()++import qualified Data.ByteString.Char8 as BS8+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Map.Merge.Strict as Map+import Distribution.Parsec+import Distribution.Parsec.Source+import Distribution.Simple.Utils (fromUTF8BS)+import Distribution.Solver.Types.ProjectConfigPath+import Distribution.Version (Version)+import Text.PrettyPrint (render)++-- Error when parsing a .cabal file++-- | Errors reported upon failing to parse a @.cabal@ file.+data CabalFileParseError+  = CabalFileParseError+      FilePath+      -- ^ @.cabal@ file path+      BS8.ByteString+      -- ^ @.cabal@ file contents+      (NonEmpty (PErrorWithSource CabalFileSource))+      -- ^ errors+      (Maybe Version)+      -- ^ We might discover the spec version the package needs+      [PWarningWithSource CabalFileSource]+      -- ^ warnings++-- | Manual instance which skips file contents+instance Show CabalFileParseError where+  showsPrec d (CabalFileParseError fp _ es mv ws) =+    showParen (d > 10) $+      showString "CabalFileParseError"+        . showChar ' '+        . showsPrec 11 fp+        . showChar ' '+        . showsPrec 11 ("" :: String)+        . showChar ' '+        . showsPrec 11 es+        . showChar ' '+        . showsPrec 11 mv+        . showChar ' '+        . showsPrec 11 ws++instance Exception CabalFileParseError where+  displayException = renderCabalFileParseError++renderCabalFileParseError :: CabalFileParseError -> String+renderCabalFileParseError (CabalFileParseError _filePath _contents errors _ warnings) =+  renderParseErrorCabalFile errors warnings++-- Error when parsing a project file++-- | Errors reported upon failing to parse a @cabal.project@ file.+data ProjectConfigParseError+  = ProjectConfigParseError+      (NonEmpty (PErrorWithSource ProjectFileSource))+      -- ^ errors+      [PWarningWithSource ProjectFileSource]+      -- ^ warnings++-- | Manual instance which skips file contents+instance Show ProjectConfigParseError where+  showsPrec d (ProjectConfigParseError es ws) =+    showParen (d > 10) $+      showString "ProjectConfigParseError"+        . showChar ' '+        . showsPrec 11 es+        . showChar ' '+        . showsPrec 11 ws++instance Exception ProjectConfigParseError where+  displayException = renderProjectConfigParseError++renderProjectConfigParseError :: ProjectConfigParseError -> String+renderProjectConfigParseError (ProjectConfigParseError errors warnings) =+  renderParseError displayProjectFileSource errors warnings+  where+    displayProjectFileSource (ProjectFileSource (path, contents)) =+      renderParseErrorFile "project" (currentProjectConfigPath path) (if isTopLevelConfigPath path then Nothing else Just $ render (docProjectImportedBy path)) contents++data ProjectFileSource = ProjectFileSource (ProjectConfigPath, BS8.ByteString) deriving (Show, Generic)++instance Eq ProjectFileSource where+  (ProjectFileSource (path1, _)) == (ProjectFileSource (path2, _)) = path1 == path2++instance Ord ProjectFileSource where+  (ProjectFileSource (path1, _)) `compare` (ProjectFileSource (path2, _)) = path1 `compare` path2++renderProjectFileSource :: ProjectFileSource -> String+renderProjectFileSource (ProjectFileSource (path, _contents)) =+  currentProjectConfigPath path++renderParseErrorCabalFile :: NonEmpty (PErrorWithSource CabalFileSource) -> [PWarningWithSource CabalFileSource] -> String+renderParseErrorCabalFile errors warnings =+  renderParseError renderCabalFileSourceMsgs errors warnings++-- | Render parse error highlighting the part of the input file.+renderParseError+  :: forall src+   . Ord src+  => (src -> ([PError], [PWarning]) -> String)+  -> NonEmpty (PErrorWithSource src)+  -> [PWarningWithSource src]+  -> String+renderParseError display errors warnings =+  unlines [renderParseErrorsWarnings (fmap display source) ws | (source, ws) <- joinedErrorsWarningsList]+  where+    mkErrorGroup :: NonEmpty (PErrorWithSource src) -> (PSource src, [PError])+    mkErrorGroup (x :| xs) = (perrorSource x, perror x : map perror xs)++    mkWarningGroup :: NonEmpty (PWarningWithSource src) -> (PSource src, [PWarning])+    mkWarningGroup (x :| xs) = (pwarningSource x, pwarning x : map pwarning xs)++    groupedErrors =+      Map.fromListWith (++) $+        map mkErrorGroup $+          NE.groupBy+            (\a b -> perrorSource a == perrorSource b)+            errors+    groupedWarnings =+      Map.fromListWith (++) $+        map mkWarningGroup $+          NE.groupBy+            (\a b -> pwarningSource a == pwarningSource b)+            warnings++    joinedErrorsWarnings :: Map.Map (PSource src) ([PError], [PWarning])+    joinedErrorsWarnings = Map.merge (Map.mapMissing (\_ es -> (es, []))) (Map.mapMissing (\_ ps -> ([], ps))) (Map.zipWithMatched (\_ es ps -> (es, ps))) groupedErrors groupedWarnings++    joinedErrorsWarningsList = Map.toList joinedErrorsWarnings++renderParseErrorsWarnings :: PSource (([PError], [PWarning]) -> String) -> ([PError], [PWarning]) -> String+renderParseErrorsWarnings source (errors, warnings) =+  case source of+    PKnownSource src -> src (errors, warnings)+    PUnknownSource -> renderParseErrorNoFile "" errors warnings++renderCabalFileSourceMsgs :: CabalFileSource -> ([PError], [PWarning]) -> String+renderCabalFileSourceMsgs (PCabalFile (fpath, contents)) (errors, warnings) =+  renderParseErrorFile "cabal" fpath Nothing contents (errors, warnings)++renderInstalledPackageInfoSourceMsgs :: InstalledPackageInfoSource -> ([PError], [PWarning]) -> String+renderInstalledPackageInfoSourceMsgs PInstalledPackageInfo (errors, warnings) =+  renderParseErrorNoFile "installed package info" errors warnings++renderParseErrorNoFile :: String -> [PError] -> [PWarning] -> String+renderParseErrorNoFile herald errors warnings =+  renderParseErrorGeneral herald Nothing Nothing (const []) errors warnings++-- | Render a parse error which resulted from a file on disk+renderParseErrorFile+  :: String+  -- ^ Human name for the kind of file (i.e. cabal, project "file")+  -> FilePath+  -- ^ Path to the file+  -> Maybe String+  -- ^ Provenance, any additional contextual info to print+  -> BS8.ByteString+  -- ^ Contents of the file+  -> ([PError], [PWarning])+  -> String+renderParseErrorFile herald filepath provenance contents (errors, warnings) =+  renderParseErrorGeneral (herald <> " file " <> filepath) (Just (filepath' <> ":")) provenance formatInput errors warnings+  where+    filepath' = normalise filepath++    -- lines of the input file. 'lines' is taken, so they are called rows+    -- contents, line number, whether it's empty line+    rows :: [(String, Int, Bool)]+    rows = zipWith f (BS8.lines contents) [1 ..]+      where+        f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s)++    rowsZipper = listToZipper rows++    isEmptyOrComment :: String -> Bool+    isEmptyOrComment s = case dropWhile (== ' ') s of+      "" -> True -- empty+      ('-' : '-' : _) -> True -- comment+      _ -> False++    -- format line: prepend the given line number+    formatInput :: Position -> [String]+    formatInput (Position row col) = case advance (row - 1) rowsZipper of+      Zipper xs ys -> before ++ after+        where+          before = case span (\(_, _, b) -> b) xs of+            (_, []) -> []+            (zs, z : _) -> map formatInputLine $ z : reverse zs++          after = case ys of+            [] -> []+            (z : _zs) ->+              [ formatInputLine z -- error line+              , "      | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^+              ]+    -- do we need rows after?+    -- ++ map formatInputLine (take 1 zs)           -- one row after++    formatInputLine :: (String, Int, Bool) -> String+    formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str++    -- hopefully we don't need to work with over 99999 lines .cabal files+    -- at that point small glitches in error messages are hopefully fine.+    leftPadShow :: Int -> String+    leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s++-- | A generic rendering function which can render from many sources.+renderParseErrorGeneral+  :: String+  -- ^ What we were parsing when the error occurred.+  -> Maybe String+  -- ^ A simpler/shorter header to display when displaying each error (normally a filepath)+  -> Maybe String+  -- ^ Provenance, used to print additional context about what file failed (used to print the import path of a project+  -- file which failed to parse)+  -> (Position -> [String])+  -- ^ Extra information to render based on the position+  -> [PError]+  -> [PWarning]+  -> String+renderParseErrorGeneral header err_header provenance extra_info errors warnings =+  unlines $+    [ warningsOrErrors <> " parsing" <> header' <> ":"+    ]+      ++ catMaybes [provenance]+      ++ [""] -- Place a newline between the header and the errors/warnings+      -- Place a newline between each error and warning+      ++ intersperse "" (renderedWarnings ++ renderedErrors)+  where+    warningsOrErrors = case errors of+      [] -> case warnings of+        [_] -> "Warning"+        _ -> "Warnings"+      [_] -> "Error"+      _ -> "Errors"++    header' = if null header then "" else " " <> header++    renderedErrors = map renderError (sortBy (comparing perrorPosition) errors)+    renderedWarnings = map renderWarning (sortBy (comparing pwarningPosition) warnings)++    renderErrorOrWarning :: String -> Position -> String -> String+    renderErrorOrWarning err_type pos msg+      -- if position is 0:0, then it doesn't make sense to show input+      -- looks like, Parsec errors have line-feed in them+      | pos == zeroPos = unlines (herald : map indent user_msg)+      | otherwise = unlines (herald : map indent (user_msg ++ extra_info pos))+      where+        herald = renderErrorHerald pos ++ err_type ++ ":"+        user_msg = lines (trimLF msg)++    indent :: String -> String+    indent s = replicate 2 ' ' ++ s++    -- Don't render the 0:0 position+    renderErrorHerald :: Position -> String+    renderErrorHerald pos =+      case (err_header, pos == zeroPos) of+        (Nothing, True) -> ""+        (Nothing, False) -> showPos pos ++ ": "+        (Just herald, True) -> herald ++ " "+        (Just herald, False) -> herald ++ showPos pos ++ ": "++    renderError :: PError -> String+    renderError (PError pos msg) = renderErrorOrWarning "error" pos msg++    renderWarning :: PWarning -> String+    renderWarning (PWarning _ pos msg) = renderErrorOrWarning "warning" pos msg++    -- sometimes there are (especially trailing) newlines.+    trimLF :: String -> String+    trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse++data Zipper a = Zipper [a] [a]++listToZipper :: [a] -> Zipper a+listToZipper = Zipper []++advance :: Int -> Zipper a -> Zipper a+advance n z@(Zipper xs ys)+  | n <= 0 = z+  | otherwise = case ys of+      [] -> z+      (y : ys') -> advance (n - 1) $ Zipper (y : xs) ys'
src/Distribution/Client/Fetch.hs view
@@ -60,6 +60,7 @@ import Distribution.System   ( Platform   )+import Distribution.Verbosity (verbosityLevel)  -- ------------------------------------------------------------ @@ -206,7 +207,7 @@           . setStrongFlags strongFlags           . setAllowBootLibInstalls allowBootLibInstalls           . setOnlyConstrained onlyConstrained-          . setSolverVerbosity verbosity+          . setSolverVerbosity (verbosityLevel verbosity)           . addConstraints             [ let pc =                     PackageConstraint
src/Distribution/Client/FetchUtils.hs view
@@ -69,7 +69,8 @@   , warn   ) import Distribution.Verbosity-  ( verboseUnmarkOutput+  ( modifyVerbosityFlags+  , verboseUnmarkOutput   )  import Control.Concurrent.Async@@ -159,11 +160,10 @@   -> Repo   -> [PackageId]   -> IO-      ( [ Either-            (Repo, PackageId) -- Verified-            (Repo, PackageId) -- unverified)-        ]-      )+      [ Either+          (Repo, PackageId) -- Verified+          (Repo, PackageId) -- unverified)+      ] verifyFetchedTarballs verbosity repoCtxt repo pkgids =   -- Establish the context once per repo (see #10110), this codepath is important   -- to be fast as it can happen when no other building happens.@@ -266,7 +266,7 @@       return res   where     -- whether we download or not is non-deterministic-    verbosity = verboseUnmarkOutput verbosity'+    verbosity = modifyVerbosityFlags verboseUnmarkOutput verbosity'      downloadRepoPackage :: IO FilePath     downloadRepoPackage = case repo of@@ -353,7 +353,7 @@           -- specifically 'AsyncCancelled' thrown at us from 'concurrently'.           result <-             Safe.try $-              fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc+              fetchPackage (modifyVerbosityFlags verboseUnmarkOutput verbosity) repoCtxt pkgloc           putMVar var result    (_, res) <-
src/Distribution/Client/FileMonitor.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-}@@ -127,17 +128,47 @@       !MonitorStateGlobRel   deriving (Show, Generic) +-- | Monitoring state for a 'Glob'. Constructors mirror those of Glob data MonitorStateGlobRel-  = MonitorStateGlobDirs+  = -- | Monitoring state for 'GlobDir'+    MonitorStateGlobDirs       !GlobPieces+      -- ^ Glob matching on subdirectory in current directory       !Glob+      -- ^ Glob tail matching on anything below subdirectory       !ModTime-      ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted-  | MonitorStateGlobFiles+      -- ^ Cached directory modification time+      ![(FilePath, MonitorStateGlobRel)]+      -- ^ Per-file monitoring state.+      -- Invariant: sorted+  | -- | Monitoring state for 'GlobFile'+    MonitorStateGlobFiles       !GlobPieces+      -- ^ Glob matching on file in current directory       !ModTime+      -- ^ Cached directory modification time       ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted-  | MonitorStateGlobDirTrailing++      -- ^ Per-file monitoring state.+      -- Invariant: sorted+  | -- | Monitoring state for 'GlobDirRecursive'+    MonitorStateGlobRecursive+      !GlobPieces+      -- ^ Glob matching on file in current directory subtree (current+      -- directory and all of its descendants).+      !ModTime+      -- ^ Cached directory modification time+      ![(FilePath, MonitorStateFileStatus)]+      -- ^ Per-file monitoring state for files immediately below the current+      -- directory.+      -- Invariant: sorted+      ![(FilePath, MonitorStateGlobRel)]+      -- ^ Monitoring state for immediate subdirectories. Transient+      -- subdirectories are represented recursively within these.+      -- Invariant: sorted+  | -- | Monitoring state for 'GlobDirTrailing'+    -- (Trivial, because there is no data in 'GlobDirTrailing')+    MonitorStateGlobDirTrailing   deriving (Show, Generic)  instance Binary MonitorStateGlob@@ -161,11 +192,19 @@     getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =       MonitorFileGlob kindfile kinddir $         RootedGlob root $-          case gstate of-            MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs-            MonitorStateGlobFiles glob _ _ -> GlobFile glob-            MonitorStateGlobDirTrailing -> GlobDirTrailing+          monitorStateGlobRelGlob gstate +-- | Reconstruct a 'Glob' from a 'MonitorStateGlobRel'. This simply erases the+-- additional information in 'MonitorStateGlobRel' added via+-- 'buildMonitorStateGlobRel'.+monitorStateGlobRelGlob :: MonitorStateGlobRel -> Glob+monitorStateGlobRelGlob gstate =+  case gstate of+    MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs+    MonitorStateGlobFiles glob _ _ -> GlobFile glob+    MonitorStateGlobRecursive glob _ _ _ -> GlobDirRecursive glob+    MonitorStateGlobDirTrailing -> GlobDirTrailing+ ------------------------------------------------------------------------------ -- Checking the status of monitored files --@@ -522,7 +561,60 @@           MonitorStateGlob kindfile kinddir globroot             <$> probeMonitorStateGlobRel kindfile kinddir root "" glob -probeMonitorStateGlobRel+probeMonitorStateFiles+  :: FilePath+  -- ^ root path+  -> FilePath+  -- ^ path of the directory we are+  --   looking in relative to @root@+  -> GlobPieces+  -- ^ file glob to filter monitored files+  -> ModTime+  -- ^ cached directory modification time+  -> [(FilePath, MonitorStateFileStatus)]+  -> ChangedM (ModTime, [(FilePath, MonitorStateFileStatus)])+probeMonitorStateFiles+  root+  dirName+  glob+  mtime+  children = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    mtime' <- case change of+      Nothing -> return mtime+      Just mtime' -> do+        -- directory modification time changed:+        -- a matching file may have been added or deleted+        matches <-+          return . filter (matchGlobPieces glob)+            =<< liftIO (listDirectory (root </> dirName))++        traverse_ probeMergeResult $+          mergeBy+            (\(path1, _) path2 -> compare path1 path2)+            children+            (sort matches)+        return mtime'++    -- Check that none of the children have changed+    for_ children $ \(file, status) ->+      probeMonitorStateFileStatus root (dirName </> file) status++    return (mtime', children)+    where+      -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use+      -- the new mtime' if any.++      probeMergeResult+        :: MergeResult (FilePath, MonitorStateFileStatus) FilePath+        -> ChangedM ()+      probeMergeResult mr = case mr of+        InBoth _ _ -> return ()+        -- this is just to be able to accurately report which file changed:+        OnlyInLeft (path, _) -> somethingChanged (dirName </> path)+        OnlyInRight path -> somethingChanged (dirName </> path)++probeMonitorStateDirs   :: MonitorKindFile   -> MonitorKindDir   -> FilePath@@ -530,14 +622,23 @@   -> FilePath   -- ^ path of the directory we are   --   looking in relative to @root@-  -> MonitorStateGlobRel-  -> ChangedM MonitorStateGlobRel-probeMonitorStateGlobRel+  -> Maybe GlobPieces+  -- ^ optional glob to filter filenames by+  -> Glob+  -- ^ glob to filter subdirectories by+  -> ModTime+  -- ^ cached directory modification time+  -> [(FilePath, MonitorStateGlobRel)]+  -> ChangedM (ModTime, [(FilePath, MonitorStateGlobRel)])+probeMonitorStateDirs   kindfile   kinddir   root   dirName-  (MonitorStateGlobDirs glob globPath mtime children) = do+  globMaybe+  globPath+  mtime+  children = do     change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime     case change of       Nothing -> do@@ -554,7 +655,7 @@               return (fname, fstate')             | (fname, fstate) <- children             ]-        return $! MonitorStateGlobDirs glob globPath mtime children'+        return $! (mtime, children')       Just mtime' -> do         -- directory modification time changed:         -- a matching subdir may have been added or deleted@@ -564,8 +665,8 @@                 let subdir = root </> dirName </> entry                  in liftIO $ doesDirectoryExist subdir             )-            . filter (matchGlobPieces glob)-            =<< liftIO (getDirectoryContents (root </> dirName))+            . maybe id (filter . matchGlobPieces) globMaybe+            =<< liftIO (listDirectory (root </> dirName))          children' <-           traverse probeMergeResult $@@ -573,7 +674,7 @@               (\(path1, _) path2 -> compare path1 path2)               children               (sort matches)-        return $! MonitorStateGlobDirs glob globPath mtime' children'+        return $! (mtime', children')     where       -- Note that just because the directory has changed, we don't force       -- a cache rewrite with 'cacheChanged' since that has some cost, and@@ -626,18 +727,57 @@             fstate         return (path, fstate') -      -- \| Does a 'MonitorStateGlob' have any relevant files within it?-      allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]-      allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =+      allMatchingFilesFromGlobFiles :: FilePath -> [(FilePath, a)] -> [FilePath]+      allMatchingFilesFromGlobFiles dir entries =         [dir </> fname | (fname, _) <- entries]-      allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =++      allMatchingFilesFromGlobDirs :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [FilePath]+      allMatchingFilesFromGlobDirs dir entries =         [ res         | (subdir, fstate) <- entries         , res <- allMatchingFiles (dir </> subdir) fstate         ]++      -- \| Does a 'MonitorStateGlob' have any relevant files within it?+      allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]+      allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =+        allMatchingFilesFromGlobFiles dir entries+      allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =+        allMatchingFilesFromGlobDirs dir entries+      allMatchingFiles dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) =+        allMatchingFilesFromGlobFiles dir fileEntries+          ++ allMatchingFilesFromGlobDirs dir dirEntries       allMatchingFiles dir MonitorStateGlobDirTrailing =         [dir]+ probeMonitorStateGlobRel+  :: MonitorKindFile+  -> MonitorKindDir+  -> FilePath+  -- ^ root path+  -> FilePath+  -- ^ path of the directory we are+  --   looking in relative to @root@+  -> MonitorStateGlobRel+  -> ChangedM MonitorStateGlobRel+probeMonitorStateGlobRel+  kindfile+  kinddir+  root+  dirName+  (MonitorStateGlobDirs glob globPath mtime children) = do+    (mtime', children') <-+      probeMonitorStateDirs+        kindfile+        kinddir+        root+        dirName+        (Just glob)+        globPath+        mtime+        children+    return $! MonitorStateGlobDirs glob globPath mtime' children'+probeMonitorStateGlobRel   _   _   root@@ -651,7 +791,7 @@         -- a matching file may have been added or deleted         matches <-           return . filter (matchGlobPieces glob)-            =<< liftIO (getDirectoryContents (root </> dirName))+            =<< liftIO (listDirectory (root </> dirName))          traverse_ probeMergeResult $           mergeBy@@ -677,6 +817,33 @@         -- this is just to be able to accurately report which file changed:         OnlyInLeft (path, _) -> somethingChanged (dirName </> path)         OnlyInRight path -> somethingChanged (dirName </> path)+probeMonitorStateGlobRel+  kindfile+  kinddir+  root+  dirName+  (MonitorStateGlobRecursive glob mtime fileChildren dirChildren) = do+    -- For recursive globs, we check the file children first, then recurse+    -- into subdirectories, applying the same logic as 'MonitorStateGlobFiles'+    -- and 'MonitorStateGlobDirs', respectively.+    (_, fileChildren') <-+      probeMonitorStateFiles+        root+        dirName+        glob+        mtime+        fileChildren+    (mtime', dirChildren') <-+      probeMonitorStateDirs+        kindfile+        kinddir+        root+        dirName+        Nothing+        (GlobDirRecursive glob)+        mtime+        dirChildren+    return $! MonitorStateGlobRecursive glob mtime' fileChildren' dirChildren' probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =   return MonitorStateGlobDirTrailing @@ -913,10 +1080,40 @@   dir   globPath = do     let absdir = root </> dir-    dirEntries <- getDirectoryContents absdir+    dirEntries <- listDirectory absdir     dirMTime <- getModTime absdir     case globPath of-      GlobDirRecursive{} -> error "Monitoring directory-recursive globs (i.e. ../**/...) is currently unsupported"+      GlobDirRecursive glob -> do+        -- evaluate globPath' over the current directory+        let files = filter (matchGlobPieces glob) dirEntries+        filesStates <-+          for (sort files) $ \file -> do+            fstate <-+              buildMonitorStateFile+                mstartTime+                hashcache+                kindfile+                kinddir+                root+                (dir </> file)+            return (file, fstate)+        -- evaluate globPath' over every subdirectory+        subdirs <-+          filterM (\subdir -> doesDirectoryExist (absdir </> subdir)) dirEntries+        subdirStates <-+          for (sort subdirs) $ \subdir -> do+            fstate <-+              buildMonitorStateGlobRel+                mstartTime+                hashcache+                kindfile+                kinddir+                root+                (dir </> subdir)+                globPath+            return (subdir, fstate)++        return $! MonitorStateGlobRecursive glob dirMTime filesStates subdirStates       GlobDir glob globPath' -> do         subdirs <-           filterM (\subdir -> doesDirectoryExist (absdir </> subdir)) $@@ -985,10 +1182,9 @@ readCacheFileHashes monitor =   handleDoesNotExist Map.empty $     handleErrorCall Map.empty $-      withCacheFile monitor $ \res ->-        case res of-          Left _ -> return Map.empty-          Right (msfs, _, _) -> return (mkFileHashCache msfs)+      withCacheFile monitor $ \case+        Left _ -> return Map.empty+        Right (msfs, _, _) -> return (mkFileHashCache msfs)   where     mkFileHashCache :: MonitorStateFileSet -> FileHashCache     mkFileHashCache (MonitorStateFileSet singlePaths globPaths) =@@ -1015,16 +1211,27 @@         , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate         ] -    collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))]-    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =+    collectDirHashes :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [(FilePath, (ModTime, HashValue))]+    collectDirHashes dir entries =       [ res       | (subdir, fstate) <- entries       , res <- collectGlobHashes (dir </> subdir) fstate       ]-    collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =++    collectFileHashes :: FilePath -> [(FilePath, MonitorStateFileStatus)] -> [(FilePath, (ModTime, HashValue))]+    collectFileHashes dir entries =       [ (dir </> fname, (mtime, hash))       | (fname, MonitorStateFileHashed mtime hash) <- entries       ]++    collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))]+    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =+      collectDirHashes dir entries+    collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =+      collectFileHashes dir entries+    collectGlobHashes dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) =+      collectFileHashes dir fileEntries+        ++ collectDirHashes dir dirEntries     collectGlobHashes _dir MonitorStateGlobDirTrailing =       []
src/Distribution/Client/Freeze.hs view
@@ -80,6 +80,7 @@ import Distribution.System   ( Platform   )+import Distribution.Verbosity (verbosityLevel) import Distribution.Version   ( thisVersion   )@@ -183,7 +184,7 @@     where       sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()       sanityCheck pkgSpecifiers = do-        when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $+        unless (null [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $           dieWithException verbosity UnexpectedNamedPkgSpecifiers         when (length pkgSpecifiers /= 1) $           dieWithException verbosity UnexpectedSourcePkgSpecifiers@@ -235,7 +236,7 @@           . setStrongFlags strongFlags           . setAllowBootLibInstalls allowBootLibInstalls           . setOnlyConstrained onlyConstrained-          . setSolverVerbosity verbosity+          . setSolverVerbosity (verbosityLevel verbosity)           . addConstraints             [ let pkg = pkgSpecifierTarget pkgSpecifier                   pc =
src/Distribution/Client/GZipUtils.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.GZipUtils -- Copyright   :  (c) Dmitry Astapov 2010@@ -24,17 +17,10 @@ import Prelude ()  import Codec.Compression.Zlib.Internal-import Data.ByteString.Lazy.Internal as BS (ByteString (Chunk, Empty))--#ifndef MIN_VERSION_zlib-#define MIN_VERSION_zlib(x,y,z) 1-#endif--#if MIN_VERSION_zlib(0,6,0) import Control.Exception (throw) import Control.Monad.ST.Lazy (ST, runST) import qualified Data.ByteString as Strict-#endif+import Data.ByteString.Lazy.Internal as BS (ByteString (Chunk, Empty))  -- | Attempts to decompress the `bytes' under the assumption that -- "data format" error at the very beginning of the stream means@@ -45,7 +31,6 @@ -- decompress without removing the content-encoding header. See: -- <https://github.com/haskell/cabal/issues/678> maybeDecompress :: ByteString -> ByteString-#if MIN_VERSION_zlib(0,6,0) maybeDecompress bytes = runST (go bytes decompressor)   where     decompressor :: DecompressStream (ST s)@@ -53,13 +38,14 @@      -- DataError at the beginning of the stream probably means that stream is     -- not compressed, so we return it as-is.-    -- TODO: alternatively, we might consider looking for the two magic bytes+    -- TODO: alternatively, we might consider looking for the two magic bytes 1F 8B+    -- (https://en.wikipedia.org/wiki/Gzip#File_structure)     -- at the beginning of the gzip header.  (not an option for zlib, though.)     go :: Monad m => ByteString -> DecompressStream m -> m ByteString-    go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k-    go _  (DecompressStreamEnd       _bs ) = return Empty-    go _  (DecompressStreamError _err    ) = return bytes-    go cs (DecompressInputRequired      k) = go cs' =<< k c+    go cs (DecompressOutputAvailable bs k) = Chunk bs <$> (go' cs =<< k)+    go _ (DecompressStreamEnd _bs) = return Empty+    go _ (DecompressStreamError _err) = return bytes+    go cs (DecompressInputRequired k) = go cs' =<< k c       where         (c, cs') = uncons cs @@ -67,27 +53,13 @@     -- and we throw them (as pure exceptions).     -- TODO: We could (and should) avoid these pure exceptions.     go' :: Monad m => ByteString -> DecompressStream m -> m ByteString-    go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k-    go' _  (DecompressStreamEnd       _bs ) = return Empty-    go' _  (DecompressStreamError err     ) = throw err-    go' cs (DecompressInputRequired      k) = go' cs' =<< k c+    go' cs (DecompressOutputAvailable bs k) = Chunk bs <$> (go' cs =<< k)+    go' _ (DecompressStreamEnd _bs) = return Empty+    go' _ (DecompressStreamError err) = throw err+    go' cs (DecompressInputRequired k) = go' cs' =<< k c       where         (c, cs') = uncons cs      uncons :: ByteString -> (Strict.ByteString, ByteString)-    uncons Empty        = (Strict.empty, Empty)+    uncons Empty = (Strict.empty, Empty)     uncons (Chunk c cs) = (c, cs)-#else-maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes-  where-    -- DataError at the beginning of the stream probably means that stream is not compressed.-    -- Returning it as-is.-    -- TODO: alternatively, we might consider looking for the two magic bytes-    -- at the beginning of the gzip header.-    foldStream (StreamError _ _) = bytes-    foldStream somethingElse = doFold somethingElse--    doFold StreamEnd               = BS.Empty-    doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)-    doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg-#endif
src/Distribution/Client/Get.hs view
@@ -24,9 +24,6 @@  import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..), srpToProxy)-import Distribution.Compat.Directory-  ( listDirectory-  ) import Distribution.Package   ( PackageId   , packageId@@ -83,6 +80,7 @@   ( createDirectoryIfMissing   , doesDirectoryExist   , doesFileExist+  , listDirectory   ) import System.FilePath   ( addTrailingPathSeparator@@ -134,8 +132,7 @@   if onlyPkgDescr     then do       when useSourceRepo $-        warn verbosity $-          "Ignoring --source-repository for --only-package-description"+        warn verbosity "Ignoring --source-repository for --only-package-description"        mapM_ (unpackOnlyPkgDescr verbosity prefix) pkgs     else
src/Distribution/Client/GlobalFlags.hs view
@@ -81,6 +81,7 @@ -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags   { globalVersion :: Flag Bool+  , globalFullVersion :: Flag Bool   , globalNumericVersion :: Flag Bool   , globalConfigFile :: Flag FilePath   , globalConstraintsFile :: Flag FilePath@@ -93,8 +94,6 @@   , globalIgnoreExpiry :: Flag Bool   -- ^ Ignore security expiry dates   , globalHttpTransport :: Flag String-  , globalNix :: Flag Bool-  -- ^ Integrate with Nix   , globalStoreDir :: Flag FilePath   , globalProgPathExtra :: NubList FilePath   -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)@@ -105,6 +104,7 @@ defaultGlobalFlags =   GlobalFlags     { globalVersion = Flag False+    , globalFullVersion = Flag False     , globalNumericVersion = Flag False     , globalConfigFile = mempty     , globalConstraintsFile = mempty@@ -115,7 +115,6 @@     , globalLogsDir = mempty     , globalIgnoreExpiry = Flag False     , globalHttpTransport = mempty-    , globalNix = Flag False     , globalStoreDir = mempty     , globalProgPathExtra = mempty     }
src/Distribution/Client/Haddock.hs view
@@ -66,7 +66,7 @@    createDirectoryIfMissing True destDir -  withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do+  withTempDirectory destDir "tmphaddock" $ \tempDir -> do     let flags =           [ "--gen-contents"           , "--gen-index"
src/Distribution/Client/HashValue.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}  module Distribution.Client.HashValue@@ -10,6 +9,7 @@   , hashFromTUF   ) where +import Control.Monad ((<=<)) import Distribution.Client.Compat.Prelude import Prelude () @@ -57,28 +57,19 @@ -- | Hash the content of a file. Uses SHA256. readFileHashValue :: FilePath -> IO HashValue readFileHashValue tarball =-  withBinaryFile tarball ReadMode $ \hnd ->-    evaluate . hashValue =<< LBS.hGetContents hnd+  withBinaryFile tarball ReadMode (evaluate . hashValue <=< LBS.hGetContents)  -- | Convert a hash from TUF metadata into a 'PackageSourceHash'. -- -- Note that TUF hashes don't necessarily have to be SHA256, since it can -- support new algorithms in future.-{- FOURMOLU_DISABLE -} hashFromTUF :: Sec.Hash -> HashValue hashFromTUF (Sec.Hash hashstr) =   -- TODO: [code cleanup] either we should get TUF to use raw bytestrings or   -- perhaps we should also just use a base16 string as the internal rep.   case Base16.decode (BS.pack hashstr) of-#if MIN_VERSION_base16_bytestring(1,0,0)-      Right hash -> HashValue hash-      Left _ -> error "hashFromTUF: cannot decode base16"-#else-      (hash, trailing) | not (BS.null hash) && BS.null trailing-        -> HashValue hash-      _ -> error "hashFromTUF: cannot decode base16 hash"-#endif-{- FOURMOLU_ENABLE -}+    Right hash -> HashValue hash+    Left _ -> error "hashFromTUF: cannot decode base16"  -- | Truncate a 32 byte SHA256 hash to --
src/Distribution/Client/HttpUtils.hs view
@@ -1,9 +1,5 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------------------------------------------------------------------------------------+{-# LANGUAGE TupleSections #-}  -- | Separate module for HTTP actions, using a proxy server if one exists. module Distribution.Client.HttpUtils@@ -241,11 +237,7 @@       _ <- P.string "#sha256="       str <- some P.hexDigit       let bs = Base16.decode (BS8.pack str)-#if MIN_VERSION_base16_bytestring(1,0,0)       either fail return bs-#else-      return (fst bs)-#endif  ------------------------------------------------------------------------------ -- Utilities for repo url management@@ -644,7 +636,7 @@               ++ " Note that the 'plain-http' transport doesn't"               ++ " support HTTPS.\n" -      when (hasRangeHeader) $ warn verbosity warningMsg+      when hasRangeHeader $ warn verbosity warningMsg       (code, etag') <- parseOutput verbosity uri resp       return (code, etag')       where@@ -661,7 +653,7 @@               ]             ++ [ "--header=" ++ show name ++ ": " ++ value                | hdr@(Header name value) <- reqHeaders-               , (not (isRangeHeader hdr))+               , not (isRangeHeader hdr)                ]          -- wget doesn't support range requests.@@ -784,8 +776,8 @@         runPowershellScript verbosity $           webclientScript             (escape (show uri))-            ( ("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")-                : (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))+            ( ("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ escape destPath ++ ", Create")+                : setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)             )             [ "$response = $request.GetResponse()"             , "$responseStream = $response.GetResponseStream()"@@ -809,8 +801,8 @@         parseResponse :: String -> IO (HttpCode, Maybe ETag)         parseResponse x =           case lines $ trim x of-            (code : etagv : _) -> fmap (\c -> (c, Just etagv)) $ parseCode code x-            (code : _) -> fmap (\c -> (c, Nothing)) $ parseCode code x+            (code : etagv : _) -> (,Just etagv) <$> parseCode code x+            (code : _) -> (,Nothing) <$> parseCode code x             _ -> statusParseFail verbosity uri x         parseCode :: String -> String -> IO HttpCode         parseCode code x = case readMaybe code of@@ -1016,7 +1008,7 @@                 HdrContentType                 ("multipart/form-data; boundary=" ++ boundary)             , Header HdrContentLength (show (LBS8.length body))-            , Header HdrAccept ("text/plain")+            , Header HdrAccept "text/plain"             ]               ++ maybeToList (authTokenHeader auth)           req =
+ src/Distribution/Client/InLibrary.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE DuplicateRecordFields #-}++module Distribution.Client.InLibrary+  ( libraryConfigureInputsFromElabPackage+  , configure+  , build+  , haddock+  , copy+  , register+  , repl+  , test+  , bench+  )+where++import Distribution.Backpack.DescribeUnitId (setupMessage')+import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.RebuildMonad+import qualified Distribution.Client.SetupHooks.CallHooksExe as ExternalHooksExe+  ( buildTypePreBuildHooks+  , buildTypeSetupHooks+  )+import Distribution.Client.Types++import qualified Distribution.PackageDescription as PD+import Distribution.Simple (Compiler, PackageDBStackCWD)+import qualified Distribution.Simple.Bench as Cabal+import Distribution.Simple.Build (build_setupHooks, repl_setupHooks)+import qualified Distribution.Simple.Configure as Cabal+import Distribution.Simple.Haddock (haddock_setupHooks)+import Distribution.Simple.Install (install_setupHooks)+import Distribution.Simple.LocalBuildInfo (mbWorkDirLBI)+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PreProcess as Cabal+import Distribution.Simple.Program.Db+import qualified Distribution.Simple.Register as Cabal+import qualified Distribution.Simple.Setup as Cabal+import Distribution.Simple.SetupHooks.Internal+import qualified Distribution.Simple.Test as Cabal+import Distribution.Simple.Utils+import Distribution.System (Platform)+import Distribution.Types.BuildType+import Distribution.Types.ComponentRequestedSpec+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Types.LocalBuildInfo+import Distribution.Utils.Path+  ( makeSymbolicPath+  , relativeSymbolicPath+  )+import Distribution.Verbosity+  ( VerbosityHandles+  , mkVerbosity+  )++import Distribution.Types.HookedBuildInfo (emptyHookedBuildInfo)+import System.Directory (canonicalizePath)++--------------------------------------------------------------------------------+-- Configure++data LibraryConfigureInputs = LibraryConfigureInputs+  { verbosityHandles :: VerbosityHandles+  , compiler :: Compiler+  , platform :: Platform+  , buildType :: BuildType+  , compRequested :: Maybe PD.ComponentName+  , localBuildConfig :: LBC.LocalBuildConfig+  , packageDBStack :: PackageDBStackCWD+  , packageDescription :: PD.PackageDescription+  , gPackageDescription :: PD.GenericPackageDescription+  , flagAssignment :: PD.FlagAssignment+  , installedPkgIndex :: InstalledPackageIndex+  }++libraryConfigureInputsFromElabPackage+  :: VerbosityHandles+  -> BuildType+  -> ProgramDb+  -> ElaboratedSharedConfig+  -> ElaboratedReadyPackage+  -> InstalledPackageIndex+  -> [String]+  -- ^ targets+  -> LibraryConfigureInputs+libraryConfigureInputsFromElabPackage+  verbHandles+  bt+  progDb+  -- NB: don't use the ProgramDb from the ElaboratedSharedConfig;+  -- that one is only for the compiler itself and not for the package.+  ElaboratedSharedConfig+    { pkgConfigPlatform = plat+    , pkgConfigCompiler = compil+    }+  (ReadyPackage pkg)+  ipi+  userTargets =+    LibraryConfigureInputs+      { verbosityHandles = verbHandles+      , compiler = compil+      , platform = plat+      , buildType =+          -- NB: don't get the build-type from 'pkgDescr',+          -- because for Configure build-type we rewrite the build-type+          -- to Simple for components that are neither the main library+          -- nor an executable.+          --+          -- See also 'isMainLibOrExeComponent'.+          bt+      , compRequested =+          case elabPkgOrComp pkg of+            ElabComponent elabComp+              | Just elabCompNm <- compComponentName elabComp ->+                  Just elabCompNm+            _ -> Nothing+      , localBuildConfig =+          LBC.LocalBuildConfig+            { LBC.extraConfigArgs = userTargets+            , LBC.withPrograms = progDb+            , LBC.withBuildOptions = elabBuildOptions pkg+            }+      , packageDBStack = elabBuildPackageDBStack pkg+      , packageDescription = pkgDescr+      , gPackageDescription = gpkgDescr+      , flagAssignment = elabFlagAssignment pkg+      , installedPkgIndex = ipi+      }+    where+      pkgDescr = elabPkgDescription pkg+      gpkgDescr = elabGPkgDescription pkg++configure+  :: LibraryConfigureInputs+  -> Cabal.ConfigFlags+  -> IO LocalBuildInfo+configure+  LibraryConfigureInputs+    { verbosityHandles = verbHandles+    , platform = plat+    , compiler = compil+    , buildType = bt+    , compRequested = mbComp+    , localBuildConfig = lbc0+    , packageDBStack = packageDBs+    , packageDescription = pkgDescr+    , gPackageDescription = gpkgDescr+    , flagAssignment = flagAssgn+    , installedPkgIndex = ipi+    }+  cfg = do+    -- Here, we essentially want to call the Cabal library 'configure' function,+    -- but skipping over all the steps we don't need such as rediscovering the+    -- compiler or re-resolving the conditionals in the package, as we have done+    -- all of that already.+    --+    -- To achieve this, we call the Cabal 'configureFinal' function which skips+    -- these preparatory steps.+    let verbFlags = Cabal.fromFlag $ Cabal.configVerbosity cfg+        verbosity = mkVerbosity verbHandles verbFlags+        mbWorkDir = Cabal.flagToMaybe $ Cabal.configWorkingDir cfg+        distPref = Cabal.fromFlag $ Cabal.configDistPref cfg+        confHooks =+          configureHooks $+            ExternalHooksExe.buildTypeSetupHooks verbosity mbWorkDir distPref bt++    let pkgId :: PD.PackageIdentifier+        pkgId = PD.package pkgDescr++    -- cabal-install uses paths relative to the current working directory,+    -- while the Cabal library expects symbolic paths. Perform the conversion here+    -- by making the paths absolute.+    packageDBs' <- traverse (traverse $ fmap makeSymbolicPath . canonicalizePath) packageDBs++    -- Configure package+    case mbComp of+      Nothing -> setupMessage verbosity "Configuring" pkgId+      Just cname ->+        setupMessage'+          verbosity+          "Configuring"+          pkgId+          cname+          (Just (Cabal.configInstantiateWith cfg))++    -- TODO: we should implement recompilation checking on the level of+    -- individual components, so that we only re-configure the components that+    -- need reconfiguring (including running their hooks). See #11761.+    lbc1 <- case preConfPackageHook confHooks of+      Nothing -> return lbc0+      Just hk -> Cabal.runPreConfPackageHook cfg compil plat lbc0 hk+    let compRequestedSpec = case mbComp of+          Just compName -> OneComponentRequestedSpec compName+          Nothing ->+            ComponentRequestedSpec+              { testsRequested = Cabal.fromFlag (Cabal.configTests cfg)+              , benchmarksRequested = Cabal.fromFlag (Cabal.configBenchmarks cfg)+              }++    -- NB: it's OK to discard constraints here: we already have a finalized PackageDescription+    -- in hand, and we are using exact UnitIds for all dependencies (this corresponds+    -- to using --exact-configuration and --dependency flags with the Setup CLI).+    (_allConstraints, pkgInfo) <-+      -- Use cabal-install's running InstalledPackageIndex 'ipi' to skip over+      -- having to invoke ghc-pkg once per package.+      --+      -- See (ProjIPI3) from Note [Per-project InstalledPackageIndex]+      -- in Distribution.Client.ProjectBuilding.+      Cabal.computePackageInfoFromIndex verbHandles cfg gpkgDescr ipi++    -- Post-configure hooks & per-component configure+    lbi1 <-+      Cabal.configureFinal+        verbHandles+        confHooks+        emptyHookedBuildInfo+        cfg+        lbc1+        (gpkgDescr, pkgDescr)+        flagAssgn+        compRequestedSpec+        compil+        plat+        packageDBs'+        pkgInfo++    -- Remember the .cabal filename if we know it.+    pkgDescrFilePath <-+      case Cabal.flagToMaybe $ Cabal.configCabalFilePath cfg of+        Just pkgFile -> return pkgFile+        Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir+    return $ lbi1{pkgDescrFile = Just pkgDescrFilePath}++--------------------------------------------------------------------------------+-- Build++build+  :: VerbosityHandles+  -> Cabal.BuildFlags+  -> LocalBuildInfo+  -> [String]+  -> IO [MonitorFilePath]+build verbHandles flags lbi _args =+  build_setupHooks (preBuildHook, postBuildHook) verbHandles pkgDescr lbi flags Cabal.knownSuffixHandlers+  where+    verb = mkVerbosity verbHandles $ Cabal.fromFlag $ Cabal.buildVerbosity flags+    hooks = ExternalHooksExe.buildTypeSetupHooks verb mbWorkDir distPref bt+    -- (Recall that pre-build hooks are treated specially;+    -- see the 'buildTypeSetupHooks' and 'buildTypePreBuildHooks' functions.)+    preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt+    postBuildHook+      | Just postBuild <- postBuildComponentHook $ buildHooks hooks =+          postBuild+      | otherwise =+          const $ return ()+    pkgDescr = localPkgDescr lbi+    bt = PD.buildType pkgDescr+    mbWorkDir = mbWorkDirLBI lbi+    distPref = Cabal.fromFlag $ Cabal.buildDistPref flags++--------------------------------------------------------------------------------+-- Haddock++haddock+  :: VerbosityHandles+  -> Cabal.HaddockFlags+  -> LocalBuildInfo+  -> [String]+  -> IO [MonitorFilePath]+haddock verbHandles flags lbi _args =+  haddock_setupHooks preBuildHook verbHandles pkgDescr lbi Cabal.knownSuffixHandlers flags+  where+    preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt+    pkgDescr = localPkgDescr lbi+    bt = PD.buildType pkgDescr+    mbWorkDir = mbWorkDirLBI lbi+    distPref = Cabal.fromFlag $ Cabal.haddockDistPref flags++--------------------------------------------------------------------------------+-- Repl++repl+  :: VerbosityHandles+  -> Cabal.ReplFlags+  -> LocalBuildInfo+  -> [String]+  -> IO [MonitorFilePath]+repl verbHandles flags lbi _args =+  repl_setupHooks preBuildHook verbHandles pkgDescr lbi flags Cabal.knownSuffixHandlers []+  where+    preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt+    pkgDescr = localPkgDescr lbi+    bt = PD.buildType pkgDescr+    mbWorkDir = mbWorkDirLBI lbi+    distPref = Cabal.fromFlag $ Cabal.replDistPref flags++--------------------------------------------------------------------------------+-- Copy++copy+  :: VerbosityHandles+  -> Cabal.CopyFlags+  -> LocalBuildInfo+  -> [String]+  -> IO ()+copy verbHandles flags lbi _args =+  install_setupHooks hooks verbHandles pkgDescr lbi flags+  where+    verb = mkVerbosity verbHandles $ Cabal.fromFlag $ Cabal.copyVerbosity flags+    hooks = installHooks $ ExternalHooksExe.buildTypeSetupHooks verb mbWorkDir distPref bt+    pkgDescr = localPkgDescr lbi+    bt = PD.buildType pkgDescr+    mbWorkDir = mbWorkDirLBI lbi+    distPref = Cabal.fromFlag $ Cabal.copyDistPref flags++--------------------------------------------------------------------------------+-- Test, bench, register.+--+-- NB: no hooks into these phases.++test+  :: VerbosityHandles+  -> Cabal.TestFlags+  -> LocalBuildInfo+  -> [String]+  -> IO ()+test verb flags lbi args =+  Cabal.test args verb pkgDescr lbi flags+  where+    pkgDescr = localPkgDescr lbi++bench+  :: VerbosityHandles+  -> Cabal.BenchmarkFlags+  -> LocalBuildInfo+  -> [String]+  -> IO ()+bench verb flags lbi args =+  Cabal.bench args verb pkgDescr lbi flags+  where+    pkgDescr = localPkgDescr lbi++register+  :: Cabal.RegisterFlags+  -> LocalBuildInfo+  -> [String]+  -> IO ()+register flags lbi _args = Cabal.register pkgDescr lbi flags+  where+    pkgDescr = localPkgDescr lbi
src/Distribution/Client/IndexUtils.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}  -- | -- Module      :  Distribution.Client.IndexUtils@@ -28,6 +28,9 @@   , getSourcePackagesAtIndexState   , ActiveRepos   , filterSkippedActiveRepos+  , applyStrategy+  , addIndex+  , deprecationAwareStrategy   , Index (..)   , RepoIndexState (..)   , PackageEntry (..)@@ -133,11 +136,10 @@   ( byteStringToFilePath   , tryReadAddSourcePackageDesc   )-import Distribution.Compat.Directory (listDirectory) import Distribution.Compat.Time (getFileAge, getModTime) import Distribution.Utils.Generic (fstOf3) import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredDecodeFileOrFail, structuredEncodeFile)-import System.Directory (doesDirectoryExist, doesFileExist)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath   ( normalise   , splitDirectories@@ -166,7 +168,7 @@ getInstalledPackages verbosity comp packageDbs progdb =   Configure.getInstalledPackages verbosity' comp Nothing (coercePackageDBStack packageDbs) progdb   where-    verbosity' = lessVerbose verbosity+    verbosity' = modifyVerbosityFlags lessVerbose verbosity  -- | Get filename base (i.e. without file extension) for index-related files --@@ -257,7 +259,7 @@   | null (repoContextRepos repoCtxt) = do       -- In the test suite, we routinely don't have any remote package       -- servers, so don't bleat about it-      warn (verboseUnmarkOutput verbosity) $+      warn (modifyVerbosityFlags verboseUnmarkOutput verbosity) $         "No remote package servers have been specified. Usually "           ++ "you would have one specified in the config file."       return@@ -353,7 +355,7 @@    pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of     Right x -> return x-    Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)+    Left err -> warn verbosity err >> return (map (,CombineStrategyMerge) pkgss)    let activeRepos' :: ActiveRepos       activeRepos' =@@ -372,16 +374,8 @@             ts /= NoTimestamp             ] -  let addIndex-        :: PackageIndex UnresolvedSourcePackage-        -> (RepoData, CombineStrategy)-        -> PackageIndex UnresolvedSourcePackage-      addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc-      addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx-      addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx-   let pkgs :: PackageIndex UnresolvedSourcePackage-      pkgs = foldl' addIndex mempty pkgss'+      pkgs = foldl' (\acc (rd, s) -> addIndex acc (rdIndex rd, rdPreferences rd, s)) mempty pkgss'    -- Note: preferences combined without using CombineStrategy   let prefs :: Map PackageName VersionRange@@ -413,6 +407,58 @@   , rdPreferences :: [Dependency]   } +-- | Fold one package index into an accumulator according to a 'CombineStrategy'.+--+-- This is the per-repository step used by 'getSourcePackagesAtIndexState' when+-- building the combined 'PackageIndex' from multiple repositories.+applyStrategy+  :: Package pkg+  => PackageIndex pkg+  -> (PackageIndex pkg, CombineStrategy)+  -> PackageIndex pkg+applyStrategy acc (_, CombineStrategySkip) = acc+applyStrategy acc (idx, CombineStrategyMerge) = PackageIndex.merge acc idx+applyStrategy acc (idx, CombineStrategyOverride) = PackageIndex.override acc idx++-- | Fold one package index and its preferred-versions into an accumulator+-- according to a 'CombineStrategy'.+--+-- Like 'applyStrategy', but for 'CombineStrategyOverride' consults the+-- repo's @preferred-versions@ via 'deprecationAwareStrategy': if all+-- versions of a package are deprecated in the override repo, merge+-- semantics are used for that package instead of override semantics.+addIndex+  :: Package pkg+  => PackageIndex pkg+  -> (PackageIndex pkg, [Dependency], CombineStrategy)+  -> PackageIndex pkg+addIndex acc (idx, prefs, CombineStrategyOverride) =+  PackageIndex.overrideOrMerge (deprecationAwareStrategy idx prefsByPkg) acc idx+  where+    prefsByPkg =+      Map.fromListWith+        intersectVersionRanges+        [(name, range) | Dependency name range _ <- prefs]+addIndex acc (idx, _, s) = applyStrategy acc (idx, s)++-- | Per-package override-or-merge decision for a 'CombineStrategyOverride' repo.+--+-- Returns 'PackageIndex.Merge' when every version of the package in the+-- override index is deprecated (i.e. excluded by the repo's+-- @preferred-versions@), so that versions from earlier repos remain visible.+-- Returns 'PackageIndex.Override' otherwise.+deprecationAwareStrategy+  :: Package pkg+  => PackageIndex pkg+  -> Map PackageName VersionRange+  -> PackageName+  -> PackageIndex.OverrideOrMerge+deprecationAwareStrategy idx prefsByPkg pkgname+  | Just pkgPrefs <- Map.lookup pkgname prefsByPkg+  , null $ PackageIndex.lookupDependency idx pkgname pkgPrefs =+      PackageIndex.Merge+  | otherwise = PackageIndex.Override+ -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. --@@ -443,7 +489,7 @@         { srcpkgPackageId = pkgid         , srcpkgDescription = pkgdesc         , srcpkgSource = case pkgEntry of-            NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing+            NormalPackage{} -> RepoTarballPackage repo pkgid Nothing             BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path         , srcpkgDescrOverride = case pkgEntry of             NormalPackage _ _ pkgtxt _ -> Just pkgtxt@@ -1284,7 +1330,7 @@     go pns pvs (x : xs) = x : go pns pvs xs      mapIntern :: Ord k => k -> Map.Map k k -> (k, Map.Map k k)-    mapIntern k m = maybe (k, Map.insert k k m) (\k' -> (k', m)) (Map.lookup k m)+    mapIntern k m = maybe (k, Map.insert k k m) (,m) (Map.lookup k m)  -- | Cabal caches various information about the Hackage index data Cache = Cache
src/Distribution/Client/IndexUtils/ActiveRepos.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}  module Distribution.Client.IndexUtils.ActiveRepos   ( ActiveRepos (..)@@ -11,6 +12,7 @@   , organizeByRepos   ) where +import Data.Bifunctor (second) import Distribution.Client.Compat.Prelude import Distribution.Client.Types.RepoName (RepoName (..)) import Prelude ()@@ -177,12 +179,10 @@     go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])     go _rest [] ys = Right (ys, [])     go rest (ActiveRepoRest s : xs) ys =-      go rest xs ys <&> \(rest', result) ->-        (rest', map (\x -> (x, s)) rest ++ result)+      go rest xs ys <&> second (map (,s) rest ++)     go rest (ActiveRepo r s : xs) ys = do       (z, zs) <- extract r ys-      go rest xs zs <&> \(rest', result) ->-        (rest', (z, s) : result)+      go rest xs zs <&> second ((z, s) :)      extract :: RepoName -> [a] -> Either String (a, [a])     extract r = loop id
src/Distribution/Client/Init.hs view
@@ -55,5 +55,5 @@       | fromFlagOrDefault False (simpleProject initFlags) =           Simple.createProject       | otherwise = case interactive initFlags of-          Flag False -> NonInteractive.createProject comp+          Flag False -> NonInteractive.createProject           _ -> Interactive.createProject
src/Distribution/Client/Init/Defaults.hs view
@@ -23,6 +23,7 @@   , defaultLicenseIds   , defaultMainIs   , defaultChangelog+  , defaultReadme   , defaultCategories   , defaultInitFlags   , defaultLanguage@@ -74,6 +75,9 @@  defaultChangelog :: FilePath defaultChangelog = "CHANGELOG.md"++defaultReadme :: FilePath+defaultReadme = "README.md"  defaultLicense :: CabalSpecVersion -> SpecLicense defaultLicense csv
src/Distribution/Client/Init/FileCreators.hs view
@@ -18,6 +18,7 @@   ( -- * Commands     writeProject   , writeLicense+  , writeReadme   , writeChangeLog   , prepareLibTarget   , prepareExeTarget@@ -53,6 +54,7 @@  import Distribution.FieldGrammar.Newtypes import Distribution.License (licenseToSPDX)+import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity) import System.FilePath ((<.>), (</>))  -- -------------------------------------------------------------------- --@@ -70,9 +72,12 @@        writeLicense opts pkgDesc       writeChangeLog opts pkgDesc+      writeReadme opts pkgDesc        let pkgFields = mkPkgDescription opts pkgDesc-          commonStanza = mkCommonStanza opts+          extensionsStanza = mkExtensionsStanza opts+          ghcOptionsStanza = mkGhcOptionsStanza opts+          rtsOptionsStanza = mkRtsOptionsStanza opts        libStanza <- prepareLibTarget opts libTarget       exeStanza <- prepareExeTarget opts exeTarget@@ -80,7 +85,7 @@        (reusedCabal, cabalContents) <-         writeCabalFile opts $-          pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]+          pkgFields ++ [extensionsStanza, ghcOptionsStanza, rtsOptionsStanza, libStanza, exeStanza, testStanza]        when (null $ _pkgSynopsis pkgDesc) $         message opts T.Warning "No synopsis given. You should edit the .cabal file and add one."@@ -240,6 +245,28 @@     go =       void $ writeFileSafe opts defaultChangelog changeLog +writeReadme :: Interactive m => WriteOpts -> PkgDescription -> m ()+writeReadme opts pkgDesc+  | Just docs <- _pkgExtraDocFiles pkgDesc+  , defaultReadme `Set.member` docs =+      go+  | defaultReadme `elem` _pkgExtraSrcFiles pkgDesc = go+  | otherwise = return ()+  where+    readme =+      unlines+        [ "# " ++ prettyShow (_pkgName pkgDesc)+        , ""+        , "## Build"+        , ""+        , "Run `$ cabal build` to build the project"+        , "## Documentation"+        , ""+        , "Run `$ cabal haddock --open` to generate a reference for the API of the project."+        ]+    go =+      void $ writeFileSafe opts defaultReadme readme+ -- -------------------------------------------------------------------- -- -- Utilities @@ -253,7 +280,7 @@ -- | Possibly generate a message to stdout, taking into account the --   --quiet flag. message :: Interactive m => WriteOpts -> T.Severity -> String -> m ()-message opts = T.message (_optVerbosity opts)+message opts = T.message (mkVerbosity defaultVerbosityHandles $ _optVerbosity opts)  -- | Write a file \"safely\" if it doesn't exist, backing up any existing version when --   the overwrite flag is set.
src/Distribution/Client/Init/FlagExtractors.hs view
@@ -138,7 +138,7 @@ getExtraDocFiles =   pure     . Just-    . flagElim (Set.singleton defaultChangelog) Set.fromList+    . flagElim (Set.fromList [defaultChangelog, defaultReadme]) Set.fromList     . extraDoc  -- | Ask whether the project builds a library or executable.
src/Distribution/Client/Init/Format.hs view
@@ -21,11 +21,13 @@   , postProcessFieldLines      -- * stanza generation-  , mkCommonStanza   , mkLibStanza   , mkExeStanza   , mkTestStanza   , mkPkgDescription+  , mkExtensionsStanza+  , mkGhcOptionsStanza+  , mkRtsOptionsStanza   ) where  import Distribution.CabalSpecVersion@@ -121,84 +123,132 @@ -- -------------------------------------------------------------------- -- -- Stanzas --- The common stanzas are hardcoded for simplicity purposes,--- see https://github.com/haskell/cabal/pull/7558#discussion_r693173846-mkCommonStanza :: WriteOpts -> PrettyField FieldAnnotation-mkCommonStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of+mkGhcOptionsStanza :: WriteOpts -> PrettyField FieldAnnotation+mkGhcOptionsStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of   NoCommonStanzas -> PrettyEmpty   _ ->     PrettySection       annNoComments       "common"-      [text "warnings"]-      [field "ghc-options" text "-Wall" [] False opts]+      [text "ghc-options"]+      [ field "ghc-options" text "-Wall -Widentities" [] False opts+      ] +mkRtsOptionsStanza :: WriteOpts -> PrettyField FieldAnnotation+mkRtsOptionsStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of+  NoCommonStanzas -> PrettyEmpty+  _ ->+    PrettySection+      annNoComments+      "common"+      [text "rts-options"]+      [ field "ghc-options" text "-rtsopts -threaded \"-with-rtsopts=-N\"" [] False opts+      ]++mkExtensionsStanza :: WriteOpts -> PrettyField FieldAnnotation+mkExtensionsStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of+  NoCommonStanzas -> PrettyEmpty+  _ ->+    PrettySection+      annNoComments+      "common"+      [text "extensions"]+      [ field "default-extensions" text "" [] False opts+      , field "default-language" text "GHC2021" [] False opts+      ]++insertCommonStanzas :: WriteOpts -> [PrettyField FieldAnnotation]+insertCommonStanzas opts =+  case specHasCommonStanzas $ _optCabalSpec opts of+    NoCommonStanzas -> [PrettyEmpty]+    _ ->+      [ field+          "import"+          (hsep . map text)+          ["extensions"]+          ["Common language extensions"]+          False+          opts+      , field+          "import"+          (hsep . map text)+          ["ghc-options"]+          ["Common compiler warnings and optimisations"]+          False+          opts+      ]++insertRtsOptionsStanza :: WriteOpts -> [PrettyField FieldAnnotation]+insertRtsOptionsStanza opts =+  case specHasCommonStanzas $ _optCabalSpec opts of+    NoCommonStanzas -> [PrettyEmpty]+    _ ->+      [ field+          "import"+          (hsep . map text)+          ["rts-options"]+          ["Common RTS options"]+          False+          opts+      ] mkLibStanza :: WriteOpts -> LibTarget -> PrettyField FieldAnnotation mkLibStanza opts (LibTarget srcDirs lang expMods otherMods exts deps tools) =   PrettySection     annNoComments     (toUTF8BS "library")     []-    [ case specHasCommonStanzas $ _optCabalSpec opts of-        NoCommonStanzas -> PrettyEmpty-        _ ->-          field-            "import"-            (hsep . map text)-            ["warnings"]-            ["Import common warning flags."]-            False-            opts-    , field-        "exposed-modules"-        formatExposedModules-        (toList expMods)-        ["Modules exported by the library."]-        True-        opts-    , field-        "other-modules"-        formatOtherModules-        otherMods-        ["Modules included in this library but not exported."]-        True-        opts-    , field-        "other-extensions"-        formatOtherExtensions-        exts-        ["LANGUAGE extensions used by modules in this package."]-        True-        opts-    , field-        "build-depends"-        formatDependencyList-        deps-        ["Other library packages from which modules are imported."]-        True-        opts-    , field-        "hs-source-dirs"-        formatHsSourceDirs-        (makeSymbolicPath <$> srcDirs)-        ["Directories containing source files."]-        True-        opts-    , field-        (buildToolTag opts)-        formatDependencyList-        tools-        ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]-        False-        opts-    , field-        "default-language"-        id-        lang-        ["Base language which the package is written in."]-        True-        opts-    ]+    ( insertCommonStanzas opts+        ++ [ field+              "exposed-modules"+              formatExposedModules+              (toList expMods)+              ["Modules exported by the library."]+              True+              opts+           , field+              "other-modules"+              formatOtherModules+              otherMods+              ["Modules included in this library but not exported."]+              True+              opts+           , field+              "other-extensions"+              formatOtherExtensions+              exts+              ["LANGUAGE extensions used by modules in this package."]+              True+              opts+           , field+              "build-depends"+              formatDependencyList+              deps+              ["Other library packages from which modules are imported."]+              True+              opts+           , field+              "hs-source-dirs"+              formatHsSourceDirs+              (makeSymbolicPath <$> srcDirs)+              ["Directories containing source files."]+              True+              opts+           , field+              (buildToolTag opts)+              formatDependencyList+              tools+              ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+              False+              opts+           , field+              "default-language"+              id+              lang+              ["Base language which the package is written in."]+              True+              opts+           ]+    )  mkExeStanza :: WriteOpts -> ExeTarget -> PrettyField FieldAnnotation mkExeStanza opts (ExeTarget exeMain appDirs lang otherMods exts deps tools) =@@ -206,142 +256,133 @@     annNoComments     (toUTF8BS "executable")     [exeName]-    [ case specHasCommonStanzas $ _optCabalSpec opts of-        NoCommonStanzas -> PrettyEmpty-        _ ->-          field-            "import"-            (hsep . map text)-            ["warnings"]-            ["Import common warning flags."]-            False-            opts-    , field-        "main-is"-        unsafeFromHs-        exeMain-        [".hs or .lhs file containing the Main module."]-        True-        opts-    , field-        "other-modules"-        formatOtherModules-        otherMods-        ["Modules included in this executable, other than Main."]-        True-        opts-    , field-        "other-extensions"-        formatOtherExtensions-        exts-        ["LANGUAGE extensions used by modules in this package."]-        True-        opts-    , field-        "build-depends"-        formatDependencyList-        deps-        ["Other library packages from which modules are imported."]-        True-        opts-    , field-        "hs-source-dirs"-        formatHsSourceDirs-        (makeSymbolicPath <$> appDirs)-        ["Directories containing source files."]-        True-        opts-    , field-        (buildToolTag opts)-        formatDependencyList-        tools-        ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]-        False-        opts-    , field-        "default-language"-        id-        lang-        ["Base language which the package is written in."]-        True-        opts-    ]+    ( insertCommonStanzas opts+        ++ insertRtsOptionsStanza opts+        ++ [ field+              "main-is"+              unsafeFromHs+              exeMain+              [".hs or .lhs file containing the Main module."]+              True+              opts+           , field+              "other-modules"+              formatOtherModules+              otherMods+              ["Modules included in this executable, other than Main."]+              True+              opts+           , field+              "other-extensions"+              formatOtherExtensions+              exts+              ["LANGUAGE extensions used by modules in this package."]+              True+              opts+           , field+              "build-depends"+              formatDependencyList+              deps+              ["Other library packages from which modules are imported."]+              True+              opts+           , field+              "hs-source-dirs"+              formatHsSourceDirs+              (makeSymbolicPath <$> appDirs)+              ["Directories containing source files."]+              True+              opts+           , field+              (buildToolTag opts)+              formatDependencyList+              tools+              ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+              False+              opts+           , field+              "default-language"+              id+              lang+              ["Base language which the package is written in."]+              True+              opts+           ]+    )   where     exeName = pretty $ _optPkgName opts  mkTestStanza :: WriteOpts -> TestTarget -> PrettyField FieldAnnotation mkTestStanza opts (TestTarget testMain dirs lang otherMods exts deps tools) =-  PrettySection-    annNoComments-    (toUTF8BS "test-suite")-    [suiteName]-    [ case specHasCommonStanzas $ _optCabalSpec opts of-        NoCommonStanzas -> PrettyEmpty-        _ ->-          field-            "import"-            (hsep . map text)-            ["warnings"]-            ["Import common warning flags."]-            False-            opts-    , field-        "default-language"-        id-        lang-        ["Base language which the package is written in."]-        True-        opts-    , field-        "other-modules"-        formatOtherModules-        otherMods-        ["Modules included in this executable, other than Main."]-        True-        opts-    , field-        "other-extensions"-        formatOtherExtensions-        exts-        ["LANGUAGE extensions used by modules in this package."]-        True-        opts-    , field-        "type"-        text-        "exitcode-stdio-1.0"-        ["The interface type and version of the test suite."]-        True-        opts-    , field-        "hs-source-dirs"-        formatHsSourceDirs-        (makeSymbolicPath <$> dirs)-        ["Directories containing source files."]-        True-        opts-    , field-        "main-is"-        unsafeFromHs-        testMain-        ["The entrypoint to the test suite."]-        True-        opts-    , field-        "build-depends"-        formatDependencyList-        deps-        ["Test dependencies."]-        True-        opts-    , field-        (buildToolTag opts)-        formatDependencyList-        tools-        ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]-        False-        opts-    ]+  let commonSections =+        case specHasCommonStanzas $ _optCabalSpec opts of+          NoCommonStanzas -> [PrettyEmpty]+          _ ->+            insertCommonStanzas opts+              ++ insertRtsOptionsStanza opts+   in PrettySection+        annNoComments+        (toUTF8BS "test-suite")+        [suiteName]+        ( commonSections+            ++ [ field+                  "default-language"+                  id+                  lang+                  ["Base language which the package is written in."]+                  True+                  opts+               , field+                  "other-modules"+                  formatOtherModules+                  otherMods+                  ["Modules included in this executable, other than Main."]+                  True+                  opts+               , field+                  "other-extensions"+                  formatOtherExtensions+                  exts+                  ["LANGUAGE extensions used by modules in this package."]+                  True+                  opts+               , field+                  "type"+                  text+                  "exitcode-stdio-1.0"+                  ["The interface type and version of the test suite."]+                  True+                  opts+               , field+                  "hs-source-dirs"+                  formatHsSourceDirs+                  (makeSymbolicPath <$> dirs)+                  ["Directories containing source files."]+                  True+                  opts+               , field+                  "main-is"+                  unsafeFromHs+                  testMain+                  ["The entrypoint to the test suite."]+                  True+                  opts+               , field+                  "build-depends"+                  formatDependencyList+                  deps+                  ["Test dependencies."]+                  True+                  opts+               , field+                  (buildToolTag opts)+                  formatDependencyList+                  tools+                  ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+                  False+                  opts+               ]+        )   where     suiteName = text $ unPackageName (_optPkgName opts) ++ "-test"
src/Distribution/Client/Init/Interactive/Command.hs view
@@ -66,6 +66,7 @@  import Distribution.License (knownLicenses) import Distribution.Parsec (simpleParsec')+import Distribution.Verbosity (verbosityFlags) import Language.Haskell.Extension (Language (..))  -- | Main driver for interactive prompt code.@@ -107,7 +108,7 @@           doOverwrite           isMinimal           cs-          v+          (verbosityFlags v)           pkgDir           pkgType           pkgName@@ -466,7 +467,7 @@     promptList       ("Choose a language for your " ++ pkgType)       [h2010, h98, ghc2021, ghc2024]-      (DefaultPrompt (maybe h2010 id lastChosenLanguage))+      (DefaultPrompt (fromMaybe h2010 lastChosenLanguage))       Nothing       True
src/Distribution/Client/Init/NonInteractive/Command.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TupleSections #-}  module Distribution.Client.Init.NonInteractive.Command   ( genPkgDescription@@ -63,19 +64,17 @@  import qualified Data.Set as Set import Distribution.FieldGrammar.Newtypes-import Distribution.Simple.Compiler import System.FilePath (splitDirectories, (</>))  -- | Main driver for interactive prompt code. createProject   :: Interactive m-  => Compiler-  -> Verbosity+  => Verbosity   -> InstalledPackageIndex   -> SourcePackageDb   -> InitFlags   -> m ProjectSettings-createProject comp v pkgIx srcDb initFlags = do+createProject v pkgIx srcDb initFlags = do   -- The workflow is as follows:   --   --  1. Get the package type, supplied as either a program input or@@ -112,17 +111,17 @@           doOverwrite           isMinimal           cs-          v+          (verbosityFlags v)           pkgDir           pkgType           pkgName    case pkgType of     Library -> do-      libTarget <- genLibTarget initFlags comp pkgIx cabalSpec+      libTarget <- genLibTarget initFlags pkgIx cabalSpec       testTarget <-         addLibDepToTest pkgName-          <$> genTestTarget initFlags comp pkgIx cabalSpec+          <$> genTestTarget initFlags pkgIx cabalSpec        return $         ProjectSettings@@ -132,7 +131,7 @@           Nothing           testTarget     Executable -> do-      exeTarget <- genExeTarget initFlags comp pkgIx cabalSpec+      exeTarget <- genExeTarget initFlags pkgIx cabalSpec        return $         ProjectSettings@@ -142,13 +141,13 @@           (Just exeTarget)           Nothing     LibraryAndExecutable -> do-      libTarget <- genLibTarget initFlags comp pkgIx cabalSpec+      libTarget <- genLibTarget initFlags pkgIx cabalSpec       exeTarget <-         addLibDepToExe pkgName-          <$> genExeTarget initFlags comp pkgIx cabalSpec+          <$> genExeTarget initFlags pkgIx cabalSpec       testTarget <-         addLibDepToTest pkgName-          <$> genTestTarget initFlags comp pkgIx cabalSpec+          <$> genTestTarget initFlags pkgIx cabalSpec        return $         ProjectSettings@@ -158,7 +157,7 @@           (Just exeTarget)           testTarget     TestSuite -> do-      testTarget <- genTestTarget initFlags comp pkgIx cabalSpec+      testTarget <- genTestTarget initFlags pkgIx cabalSpec        return $         ProjectSettings@@ -190,15 +189,14 @@ genLibTarget   :: Interactive m   => InitFlags-  -> Compiler   -> InstalledPackageIndex   -> CabalSpecVersion   -> m LibTarget-genLibTarget flags comp pkgs v = do+genLibTarget flags pkgs v = do   srcDirs <- srcDirsHeuristics flags   let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs   LibTarget srcDirs-    <$> languageHeuristics flags comp+    <$> languageHeuristics flags     <*> exposedModulesHeuristics flags     <*> libOtherModulesHeuristics flags     <*> otherExtsHeuristics flags srcDir@@ -208,17 +206,16 @@ genExeTarget   :: Interactive m   => InitFlags-  -> Compiler   -> InstalledPackageIndex   -> CabalSpecVersion   -> m ExeTarget-genExeTarget flags comp pkgs v = do+genExeTarget flags pkgs v = do   appDirs <- appDirsHeuristics flags   let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs   ExeTarget     <$> mainFileHeuristics flags     <*> pure appDirs-    <*> languageHeuristics flags comp+    <*> languageHeuristics flags     <*> exeOtherModulesHeuristics flags     <*> otherExtsHeuristics flags appDir     <*> dependenciesHeuristics flags appDir pkgs@@ -227,11 +224,10 @@ genTestTarget   :: Interactive m   => InitFlags-  -> Compiler   -> InstalledPackageIndex   -> CabalSpecVersion   -> m (Maybe TestTarget)-genTestTarget flags comp pkgs v = do+genTestTarget flags pkgs v = do   initialized <- initializeTestSuiteHeuristics flags   testDirs' <- testDirsHeuristics flags   let testDir = fromMaybe defaultTestDir $ safeHead testDirs'@@ -242,7 +238,7 @@         TestTarget           <$> testMainHeuristics flags           <*> pure testDirs'-          <*> languageHeuristics flags comp+          <*> languageHeuristics flags           <*> testOtherModulesHeuristics flags           <*> otherExtsHeuristics flags testDir           <*> dependenciesHeuristics flags testDir pkgs@@ -361,8 +357,8 @@ testDirsHeuristics flags = getTestDirs flags $ return [defaultTestDir]  -- | Ask for the Haskell base language of the package.-languageHeuristics :: Interactive m => InitFlags -> Compiler -> m Language-languageHeuristics flags comp = getLanguage flags $ guessLanguage comp+languageHeuristics :: Interactive m => InitFlags -> m Language+languageHeuristics flags = getLanguage flags $ return defaultLanguage  -- | Ask whether to generate explanatory comments. noCommentsHeuristics :: Interactive m => InitFlags -> m Bool@@ -493,11 +489,12 @@         Flag x -> x         NoFlag -> map moduleName sources -      groupedDeps = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources+      groupedDeps = concatMap (\s -> map (moduleName s,) (imports s)) sources       filteredDeps = filter ((`notElem` mods) . snd) groupedDeps       preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps+      verbosity = mkVerbosity defaultVerbosityHandles (fromFlagOrDefault normal $ initVerbosity flags) -  retrieveDependencies (fromFlagOrDefault normal $ initVerbosity flags) flags preludeNub pkgIx+  retrieveDependencies verbosity flags preludeNub pkgIx  -- | Retrieve the list of extensions otherExtsHeuristics :: Interactive m => InitFlags -> FilePath -> m [Extension]
src/Distribution/Client/Init/NonInteractive/Heuristics.hs view
@@ -22,7 +22,6 @@   , guessAuthorName   , guessAuthorEmail   , guessCabalSpecVersion-  , guessLanguage   , guessPackageType   , guessSourceDirectories   , guessApplicationDirectories@@ -32,6 +31,7 @@  import Distribution.Simple.Setup (fromFlagOrDefault) +import Data.Functor ((<&>)) import qualified Data.List as L import qualified Data.Set as Set import Distribution.CabalSpecVersion@@ -40,10 +40,9 @@ import Distribution.Client.Init.Types import Distribution.Client.Init.Utils import Distribution.FieldGrammar.Newtypes-import Distribution.Simple.Compiler+import Distribution.Simple.Utils (ordNub) import Distribution.Types.PackageName (PackageName) import Distribution.Version-import Language.Haskell.Extension import System.FilePath  -- | Guess the main file, returns a default value if none is found.@@ -71,15 +70,6 @@       _ -> Just defaultCabalVersion     Nothing -> pure defaultCabalVersion --- | Guess the language specification based on the GHC version-guessLanguage :: Interactive m => Compiler -> m Language-guessLanguage Compiler{compilerId = CompilerId GHC ver} =-  return $-    if ver < mkVersion [7, 0, 1]-      then Haskell98-      else Haskell2010-guessLanguage _ = return defaultLanguage- -- | Guess the package name based on the given root directory. guessPackageName :: Interactive m => FilePath -> m PackageName guessPackageName = filePathToPkgName@@ -93,7 +83,7 @@ guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath)) guessExtraDocFiles flags = do   pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags-  files <- getDirectoryContents pkgDir+  files <- listDirectory pkgDir    let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"]       extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)]@@ -101,7 +91,7 @@   return $     Just $       if null extraDocs-        then Set.singleton defaultChangelog+        then Set.fromList [defaultChangelog, defaultReadme]         else Set.fromList extraDocs  -- | Try to guess the package type from the files in the package directory,@@ -144,17 +134,16 @@   let candidates = [defaultApplicationDir, "app", "src-exe"]    in return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of         [] -> [defaultApplicationDir]-        x -> map (</> pkgDirs) . nub $ x+        x -> map (</> pkgDirs) (ordNub x)  -- | Try to guess the source directories, using a default value as fallback. guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath] guessSourceDirectories flags = do   pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags -  doesDirectoryExist (pkgDir </> "src")-    >>= return . \case-      False -> [defaultSourceDir]-      True -> ["src"]+  doesDirectoryExist (pkgDir </> "src") <&> \case+    False -> [defaultSourceDir]+    True -> ["src"]  -- | Guess author and email using git configuration options. guessAuthorName :: Interactive m => m (Maybe String)
src/Distribution/Client/Init/Prompt.hs view
@@ -152,7 +152,7 @@   -- ^ pretty-printer   -> String   -- ^ prompt message-  -> (DefaultPrompt t)+  -> DefaultPrompt t   -- ^ optional default value   -> m t promptDefault parse pprint msg def = do
src/Distribution/Client/Init/Simple.hs view
@@ -45,7 +45,7 @@           doOverwrite           isMinimal           cs-          v+          (verbosityFlags v)           pkgDir           pkgType           pkgName@@ -112,7 +112,7 @@ genSimplePkgDesc :: Interactive m => InitFlags -> m PkgDescription genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName   where-    defaultExtraDoc = Just $ Set.singleton defaultChangelog+    defaultExtraDoc = Just $ Set.fromList [defaultChangelog, defaultReadme]      extractExtraDoc [] = defaultExtraDoc     extractExtraDoc fs = Just $ Set.fromList fs
src/Distribution/Client/Init/Types.hs view
@@ -81,7 +81,8 @@ import Distribution.ModuleName import qualified Distribution.Package as P import Distribution.Simple.Setup (Flag)-import Distribution.Verbosity (silent)+import qualified Distribution.Simple.Utils as P+import Distribution.Verbosity (VerbosityFlags, VerbosityLevel (..), verbosityLevel) import Distribution.Version import Language.Haskell.Extension (Extension, Language (..)) import qualified System.IO@@ -129,7 +130,7 @@   , initializeTestSuite :: Flag Bool   , testDirs :: Flag [String]   , initHcPath :: Flag FilePath-  , initVerbosity :: Flag Verbosity+  , initVerbosity :: Flag VerbosityFlags   , overwrite :: Flag Bool   }   deriving (Eq, Show, Generic)@@ -209,7 +210,7 @@   { _optOverwrite :: Bool   , _optMinimal :: Bool   , _optNoComments :: Bool-  , _optVerbosity :: Verbosity+  , _optVerbosity :: VerbosityFlags   , _optPkgDir :: FilePath   , _optPkgType :: PackageType   , _optPkgName :: P.PackageName@@ -299,7 +300,7 @@  runPromptIO :: PromptIO a -> IO a runPromptIO (PromptIO pio) =-  (Data.IORef.newIORef newSessionState) >>= (runReaderT pio)+  Data.IORef.newIORef newSessionState >>= runReaderT pio  type Inputs = NonEmpty String @@ -341,7 +342,6 @@   readFile :: FilePath -> m String   getCurrentDirectory :: m FilePath   getHomeDirectory :: m FilePath-  getDirectoryContents :: FilePath -> m [FilePath]   listDirectory :: FilePath -> m [FilePath]   doesDirectoryExist :: FilePath -> m Bool   doesFileExist :: FilePath -> m Bool@@ -371,10 +371,10 @@    -- session state functions   getLastChosenLanguage :: m (Maybe String)-  setLastChosenLanguage :: (Maybe String) -> m ()+  setLastChosenLanguage :: Maybe String -> m ()  newtype SessionState = SessionState-  { lastChosenLanguage :: (Maybe String)+  { lastChosenLanguage :: Maybe String   }  newSessionState :: SessionState@@ -385,7 +385,6 @@   readFile = liftIO <$> P.readFile   getCurrentDirectory = liftIO P.getCurrentDirectory   getHomeDirectory = liftIO P.getHomeDirectory-  getDirectoryContents = liftIO <$> P.getDirectoryContents   listDirectory = liftIO <$> P.listDirectory   doesDirectoryExist = liftIO <$> P.doesDirectoryExist   doesFileExist = liftIO <$> P.doesFileExist@@ -403,14 +402,14 @@   putStr = liftIO <$> P.putStr   putStrLn = liftIO <$> P.putStrLn   createDirectory = liftIO <$> P.createDirectory-  removeDirectory = liftIO <$> P.removeDirectoryRecursive+  removeDirectory = liftIO <$> P.removePathForcibly   writeFile a b = liftIO $ P.writeFile a b-  removeExistingFile = liftIO <$> P.removeExistingFile+  removeExistingFile = liftIO <$> P.removeFileForcibly   copyFile a b = liftIO $ P.copyFile a b   renameDirectory a b = liftIO $ P.renameDirectory a b   hFlush = liftIO <$> System.IO.hFlush   message q severity msg-    | q == silent = pure ()+    | verbosityLevel q == Silent = pure ()     | otherwise = putStrLn $ "[" ++ displaySeverity severity ++ "] " ++ msg   break = return False   throwPrompt = liftIO <$> throwM@@ -433,7 +432,6 @@   getHomeDirectory = popAbsolute    -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]"-  getDirectoryContents !_ = popList   listDirectory !_ = popList   doesDirectoryExist !_ = popBool   doesFileExist !_ = popBool@@ -501,7 +499,7 @@ checkInvalidPath path act =   -- The check below is done this way so it's easier to append   -- more invalid paths in the future, if necessary-  if path `elem` ["."]+  if path == "."     then throwPrompt $ BreakException $ "Invalid path: " ++ path     else return act
src/Distribution/Client/Init/Utils.hs view
@@ -48,7 +48,7 @@ import Distribution.Types.LibraryName import Distribution.Types.PackageName import Distribution.Utils.String (trim)-import Distribution.Verbosity (silent)+import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity, silent) import Distribution.Version  -- | Data type of source files found in the working directory@@ -176,7 +176,7 @@ -- | Given a module, retrieve all of its language pragmas retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension] retrieveModuleExtensions m = do-  catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m+  mapMaybe (simpleParsec . trim) . grabModuleExtensions <$> readFile m   where     stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#') @@ -323,7 +323,7 @@ getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency] getBaseDep pkgIx flags =   retrieveDependencies-    silent+    (mkVerbosity defaultVerbosityHandles silent)     flags     [(fromString "Prelude", fromString "Prelude")]     pkgIx
src/Distribution/Client/Install.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TupleSections #-}  ----------------------------------------------------------------------------- @@ -48,9 +49,8 @@   ( createDirectoryIfMissing   , doesDirectoryExist   , doesFileExist-  , getDirectoryContents   , getTemporaryDirectory-  , removeFile+  , listDirectory   , renameDirectory   ) import System.FilePath@@ -116,7 +116,8 @@   , filterTestFlags   ) import Distribution.Client.SetupWrapper-  ( SetupScriptOptions (..)+  ( SetupRunnerArgs (NotInLibrary)+  , SetupScriptOptions (..)   , defaultSetupScriptOptions   , setupWrapper   )@@ -228,6 +229,7 @@ import Distribution.Simple.Utils   ( VerboseException   , createDirectoryIfMissingVerbose+  , ordNub   , writeFileAtomic   ) import Distribution.Simple.Utils as Utils@@ -236,6 +238,7 @@   , dieWithException   , info   , notice+  , removeFileForcibly   , warn   , withTempDirectory   )@@ -265,11 +268,7 @@   , thisPackageVersionConstraint   ) import Distribution.Utils.NubList-import Distribution.Verbosity as Verbosity-  ( modifyVerbosity-  , normal-  , verbose-  )+import Distribution.Verbosity import Distribution.Version   ( Version   , VersionRange@@ -277,6 +276,7 @@   )  import qualified Data.ByteString as BS+import Data.Foldable (fold) import Distribution.Client.Errors  -- TODO:@@ -339,7 +339,7 @@           ++ "see https://github.com/haskell/cabal/issues/3353"           ++ " (if you didn't type --root-cmd, comment out root-cmd"           ++ " in your ~/.config/cabal/config file)"-    let userOrSandbox = fromFlag (configUserInstall configFlags)+    let userOrSandbox = fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)     unless userOrSandbox $       warn verbosity $         "the --global flag is deprecated -- "@@ -607,7 +607,7 @@           . setStrongFlags strongFlags           . setAllowBootLibInstalls allowBootLibInstalls           . setOnlyConstrained onlyConstrained-          . setSolverVerbosity verbosity+          . setSolverVerbosity (verbosityLevel verbosity)           . setPreferenceDefault             ( if upgradeDeps                 then PreferAllLatest@@ -713,7 +713,7 @@         ++ "required by a dependency of one of the other targets."       where         pkgids =-          nub+          ordNub             [ depid             | SolverInstallPlan.PackageMissingDeps _ depids <- problems             , depid <- depids@@ -782,7 +782,7 @@     -- likely to be broken. We exclude packages that are already broken.     let newBrokenPkgs =           filter-            (\p -> not (Installed.installedUnitId p `elem` excluded))+            (\p -> Installed.installedUnitId p `notElem` excluded)             (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)     let containsReinstalls = not (null reinstalledPkgs)     let breaksPkgs = not (null newBrokenPkgs)@@ -790,7 +790,7 @@     let adaptedVerbosity           | containsReinstalls           , not overrideReinstall =-              modifyVerbosity (max verbose) verbosity+              modifyVerbosityFlags makeVerbose verbosity           | otherwise = verbosity      -- We print the install plan if we are in a dry-run or if we are confronted@@ -811,13 +811,7 @@               "The following packages are likely to be broken by the reinstalls:"                 : map (prettyShow . mungedId) newBrokenPkgs                 ++ if overrideReinstall-                  then-                    if dryRun-                      then []-                      else-                        [ "Continuing even though "-                            ++ "the plan contains dangerous reinstalls."-                        ]+                  then ["Continuing even though the plan contains dangerous reinstalls." | not dryRun]                   else ["Use --force-reinstalls if you want to install anyway."]       if breaksPkgs         then do@@ -916,7 +910,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of   [] -> return ()   pkgs-    | verbosity >= Verbosity.verbose ->+    | verbosityLevel verbosity >= Verbose ->         notice verbosity $           unlines $             ("In order, the following " ++ wouldWill ++ " be installed:")@@ -936,7 +930,7 @@      showPkg (pkg, _) =       prettyShow (packageId pkg)-        ++ showLatest (pkg)+        ++ showLatest pkg      showPkgAndReason (ReadyPackage pkg', pr) =       unwords@@ -961,7 +955,7 @@     showLatest pkg = case mLatestVersion of       Just latestVersion ->         if packageVersion pkg < latestVersion-          then ("(latest: " ++ prettyShow latestVersion ++ ")")+          then "(latest: " ++ prettyShow latestVersion ++ ")"           else ""       Nothing -> ""       where@@ -1011,7 +1005,7 @@                 )             )           _ <--          CD.flatDeps (confPkgDeps cpkg)+          fold (confPkgDeps cpkg)       ]      revDeps :: Map.Map PackageId [PackageId]@@ -1207,8 +1201,8 @@         createDirectoryIfMissing True reportsDir -- FIXME         writeFile reportFile (show (showBuildReport report, buildLog))     | (report, Just repo) <- reports-    , Just remoteRepo <- [maybeRepoRemote repo]     , isLikelyToHaveLogFile (BuildReports.installOutcome report)+    , Just remoteRepo <- [maybeRepoRemote repo]     ]   where     isLikelyToHaveLogFile BuildReports.ConfigureFailed{} = True@@ -1249,7 +1243,7 @@         defaultDirs <-           InstallDirs.defaultInstallDirs             (compilerFlavor comp)-            (fromFlag (configUserInstall configFlags))+            (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))             True         let indexFileTemplate = fromFlag (installHaddockIndex installFlags)             indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate@@ -1438,7 +1432,7 @@     )   installedPkgIndex   installPlan = do-    info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."+    info verbosity $ "Number of threads used: " ++ show numJobs ++ "."      jobControl <-       if parallelInstall@@ -1503,7 +1497,6 @@           distPref           (chooseCabalVersion configExFlags (libVersion miscOptions))           (Just lock)-          parallelInstall           index           (Just rpkg) @@ -1514,7 +1507,7 @@       useLogFile :: UseLogFile       useLogFile =         fmap-          ((\f -> (f, loggingVerbosity)) . substLogFileName)+          ((,loggingVerbosity) . substLogFileName)           logFileTemplate         where           installLogFile' = flagToMaybe $ installLogFile installFlags@@ -1535,7 +1528,7 @@           -- --build-log, use more verbose logging.           loggingVerbosity :: Verbosity           loggingVerbosity-            | overrideVerbosity = modifyVerbosity (max verbose) verbosity+            | overrideVerbosity = modifyVerbosityFlags makeVerbose verbosity             | otherwise = verbosity            useDefaultTemplate :: Bool@@ -1598,7 +1591,7 @@       (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid)       (Left _) -> do         notice verbosity $ "Failed to install " ++ prettyShow pkgid-        when (verbosity >= normal) $+        when (verbosityLevel verbosity >= Normal) $           case useLogFile of             Nothing -> return ()             Just (mkLogFileName, _) -> do@@ -1753,7 +1746,7 @@   distPref   installPkg = do     tmp <- getTemporaryDirectory-    withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->+    withTempDirectory tmp "cabal-tmp" $ \tmpDirPath ->       onFailure UnpackFailed $ do         let relUnpackedPath = prettyShow pkgid             absUnpackedPath = tmpDirPath </> relUnpackedPath@@ -1869,7 +1862,7 @@           (`filterCommonFlags` ver) $             defaultCommonSetupFlags               { setupDistPref = setupDistPref $ configCommonFlags configFlags-              , setupVerbosity = toFlag verbosity'+              , setupVerbosity = toFlag $ verbosityFlags verbosity'               , setupWorkingDir = maybeToFlag mbWorkDir               } @@ -1882,8 +1875,8 @@           filterConfigureFlags             configFlags'               { configCommonFlags =-                  (configCommonFlags (configFlags'))-                    { setupVerbosity = toFlag verbosity'+                  (configCommonFlags configFlags')+                    { setupVerbosity = toFlag $ verbosityFlags verbosity'                     }               } @@ -1968,7 +1961,7 @@                     _ -> ipkgs               let packageDBs =                     interpretPackageDbFlags-                      (fromFlag (configUserInstall configFlags))+                      (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))                       (configPackageDBs configFlags)               for_ ipkgs' $ \ipkg' ->                 registerPackage@@ -2022,7 +2015,7 @@         -> IO [Installed.InstalledPackageInfo]       genPkgConfs flags mLogPath = do         tmp <- getTemporaryDirectory-        withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do+        withTempDirectory tmp (tempTemplate "pkgConf") $ \dir -> do           let pkgConfDest = makeSymbolicPath dir </> makeRelativePathEx "pkgConf"               registerFlags' version =                 (flags version)@@ -2041,7 +2034,7 @@             -- configurations is well formed                traverse (readPkgConf (getSymbolicPath pkgConfDest)) . sort . filter notHidden-                =<< getDirectoryContents (getSymbolicPath pkgConfDest)+                =<< listDirectory (getSymbolicPath pkgConfDest)             else fmap (: []) $ readPkgConf "." (getSymbolicPath pkgConfDest)        readPkgConf@@ -2070,17 +2063,16 @@             let logFileName = mkLogFileName (packageId pkg) uid                 logDir = takeDirectory logFileName             unless (null logDir) $ createDirectoryIfMissing True logDir-            logFileExists <- doesFileExist logFileName-            when logFileExists $ removeFile logFileName+            removeFileForcibly logFileName             return (Just logFileName)        setup cmd getCommonFlags flags mLogPath =         Exception.bracket-          (traverse (\path -> openFile path AppendMode) mLogPath)+          (traverse (`openFile` AppendMode) mLogPath)           (traverse_ hClose)           ( \logFileHandle ->               setupWrapper-                verbosity+                (setVerbosityHandles logFileHandle verbosity)                 scriptOptions                   { useLoggingHandle = logFileHandle                   , useWorkingDir = makeSymbolicPath <$> workingDir@@ -2090,6 +2082,7 @@                 getCommonFlags                 flags                 (const [])+                NotInLibrary           )  -- helper@@ -2124,7 +2117,7 @@   defaultDirs <-     InstallDirs.defaultInstallDirs       compFlavor-      (fromFlag (configUserInstall configFlags))+      (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))       (PackageDescription.hasLibs pkg)    Win32SelfUpgrade.possibleSelfUpgrade
src/Distribution/Client/InstallPlan.hs view
@@ -18,7 +18,20 @@ -- Stability   :  provisional -- Portability :  portable ----- Package installation plan+-- Package installation plan.+--+-- === Warning+--+-- 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'+-- intentionally have no 'Distribution.Package.PackageInstalled' instance.+--+-- @PackageInstalled@ returns only library dependencies, but for a package that+-- isn't yet installed we know many more kinds of dependencies (setup+-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on+-- dependencies in @cabal-install@ should consider what to do with these+-- dependencies; if we give a @PackageInstalled@ instance it would be too easy+-- to get this wrong (and, for instance, call graph traversal functions from+-- @Cabal@ rather than from @cabal-install@). module Distribution.Client.InstallPlan   ( InstallPlan   , GenericInstallPlan@@ -158,21 +171,18 @@ -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. --- | Packages in an install plan------ NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'--- intentionally have no 'PackageInstalled' instance. `This is important:--- PackageInstalled returns only library dependencies, but for package that--- aren't yet installed we know many more kinds of dependencies (setup--- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on--- dependencies in cabal-install should consider what to do with these--- dependencies; if we give a 'PackageInstalled' instance it would be too easy--- to get this wrong (and, for instance, call graph traversal functions from--- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.+-- | Packages in an install plan, either pre-existing installed `ipkg` packages+-- or source `srcpkg` packages. data GenericPlanPackage ipkg srcpkg-  = PreExisting ipkg-  | Configured srcpkg-  | Installed srcpkg+  = -- | A package that is already installed. These have fixed dependencies+    -- having already been built.+    PreExisting ipkg+  | -- | A package that is not yet installed but is configured and constrained+    -- in its dependencies.+    Configured srcpkg+  | -- | An installed package that is also available as a source package meaning+    -- that it could be re-installed if required.+    Installed srcpkg   deriving (Eq, Show, Generic)  displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String@@ -689,8 +699,7 @@   => GenericInstallPlan ipkg srcpkg   -> ([GenericReadyPackage srcpkg], Processing) ready plan =-  assert (processingInvariant plan processing) $-    (readyPackages, processing)+  assert (processingInvariant plan processing) (readyPackages, processing)   where     !processing =       Processing@@ -720,7 +729,8 @@   -> ([GenericReadyPackage srcpkg], Processing) completed plan (Processing processingSet completedSet failedSet) pkgid =   assert (pkgid `Set.member` processingSet) $-    assert (processingInvariant plan processing') $+    assert+      (processingInvariant plan processing')       ( map asReadyPackage newlyReady       , processing'       )@@ -760,7 +770,8 @@         -- but note that some newlyFailed may already be in the failed set         -- since one package can depend on two packages that both fail and         -- so would be in the rev-dep closure for both.-        assert (processingInvariant plan processing') $+        assert+          (processingInvariant plan processing')           ( map asConfiguredPackage (drop 1 newlyFailed)           , processing'           )@@ -783,9 +794,9 @@   -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) =   -- All the packages in the three sets are actually in the graph-  assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet)-    $ assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet)-    $ assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet)+  assert (Foldable.all (`Graph.member` planGraph plan) processingSet)+    $ assert (Foldable.all (`Graph.member` planGraph plan) completedSet)+    $ assert (Foldable.all (`Graph.member` planGraph plan) failedSet)     $     -- The processing, completed and failed sets are disjoint from each other     assert (noIntersection processingSet completedSet)@@ -1070,7 +1081,7 @@        | pkg <- Foldable.toList graph        , Just pkg' <-           map-            (flip Graph.lookup graph)+            (`Graph.lookup` graph)             (nodeNeighbors pkg)        , not (stateDependencyRelation pkg pkg')        ]
src/Distribution/Client/InstallSymlink.hs view
@@ -61,10 +61,9 @@ import Distribution.Simple.Setup   ( ConfigFlags (..)   , flagToMaybe-  , fromFlag   , fromFlagOrDefault   )-import Distribution.Simple.Utils (info, withTempDirectory)+import Distribution.Simple.Utils (info, removeFileForcibly, withTempDirectory) import Distribution.System   ( Platform   )@@ -75,8 +74,10 @@  import System.Directory   ( canonicalizePath+  , createFileLink+  , getSymbolicLinkTarget   , getTemporaryDirectory-  , removeFile+  , pathIsSymbolicLink   ) import System.FilePath   ( isAbsolute@@ -94,7 +95,7 @@   , isDoesNotExistError   ) -import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)+import Distribution.Client.Config (defaultUserInstall) import Distribution.Client.Init.Prompt (promptYesNo) import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt), runPromptIO) import Distribution.Client.Types.OverwritePolicy@@ -217,7 +218,7 @@         defaultDirs <-           InstallDirs.defaultInstallDirs             compilerFlavor-            (fromFlag (configUserInstall configFlags))+            (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))             (PackageDescription.hasLibs pkg)         let templateDirs =               InstallDirs.combineInstallDirs@@ -320,7 +321,7 @@     mkLink = True <$ createFileLink (relativeBindir </> privateName) (publicBindir </> publicName)      rmLink :: IO Bool-    rmLink = True <$ removeFile (publicBindir </> publicName)+    rmLink = True <$ removeFileForcibly (publicBindir </> publicName)      overwrite :: IO Bool     overwrite = rmLink *> mkLink@@ -394,7 +395,7 @@ trySymlink :: Verbosity -> IO Bool trySymlink verbosity = do   tmp <- getTemporaryDirectory-  withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do+  withTempDirectory tmp "cabal-symlink-test" $ \tmpDirPath -> do     let from = tmpDirPath </> "file.txt"     let to = tmpDirPath </> "file2.txt" @@ -405,7 +406,7 @@     let create :: IO Bool         create = do           createFileLink from to-          info verbosity $ "Symlinking seems to work"+          info verbosity "Symlinking seems to work"           return True      create `catchIO` \exc -> do
src/Distribution/Client/JobControl.hs view
@@ -45,7 +45,7 @@ import Control.Concurrent.MVar import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar) import Control.Concurrent.STM.TChan-import Control.Exception (bracket, bracket_, mask_, try)+import Control.Exception (bracket, bracket_, finally, mask_, try) import Control.Monad (forever, replicateM_) import Distribution.Client.Compat.Semaphore import Distribution.Client.Utils (numberOfProcessors)@@ -72,9 +72,9 @@   , cleanupJobControl :: m ()   -- ^ cleanup any resources created by the JobControl, intended to be used   -- as the finaliser for `bracket`.-  , jobControlSemaphore :: Maybe SemaphoreName-  -- ^ Name of the semaphore which can be used to control parallelism, if one-  -- is available for that job control type.+  , jobControlSemaphore :: Maybe SemaphoreIdentifier+  -- ^ Identifier of the semaphore which can be used to control parallelism,+  -- if one is available for that job control type.   }  -- | Make a 'JobControl' that executes all jobs serially and in order.@@ -183,40 +183,48 @@   | n < 1 || n > 1000 =       error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n newSemaphoreJobControl verbosity maxJobLimit = do-  sem <- freshSemaphore "cabal_semaphore" maxJobLimit-  info verbosity $-    "Created semaphore called "-      ++ getSemaphoreName (semaphoreName sem)-      ++ " with "-      ++ show maxJobLimit-      ++ " slots."-  outqVar <- newTChanIO-  inqVar <- newTChanIO-  countVar <- newTVarIO 0-  void (forkIO (worker sem inqVar outqVar))-  return-    JobControl-      { spawnJob = spawn inqVar countVar-      , collectJob = collect outqVar countVar-      , remainingJobs = remaining countVar-      , cancelJobs = cancel inqVar countVar-      , cleanupJobControl = destroySemaphore sem-      , jobControlSemaphore = Just (semaphoreName sem)-      }+  mbServer <- freshSemaphore "cabal_semaphore" maxJobLimit+  case mbServer of+    Left err -> do+      warn verbosity $+        "Failed to create semaphore: "+          ++ show err+          ++ "; falling back to -j"+          ++ show maxJobLimit+          ++ "."+      newParallelJobControl maxJobLimit+    Right server -> do+      let sem = serverClientSemaphore server+      info verbosity $+        "Created semaphore called "+          ++ semaphoreIdentifier (clientSemaphoreName sem)+          ++ " with "+          ++ show maxJobLimit+          ++ " slots."+      outqVar <- newTChanIO+      inqVar <- newTChanIO+      countVar <- newTVarIO 0+      void (forkIO (worker sem inqVar outqVar))+      return+        JobControl+          { spawnJob = spawn inqVar countVar+          , collectJob = collect outqVar countVar+          , remainingJobs = remaining countVar+          , cancelJobs = cancel inqVar countVar+          , cleanupJobControl = destroyServerSemaphore server+          , jobControlSemaphore = Just (semaphoreIdentifier (clientSemaphoreName sem))+          }   where-    worker :: Semaphore -> TChan (IO a) -> TChan (Either SomeException a) -> IO ()+    worker :: ClientSemaphore -> TChan (IO a) -> TChan (Either SomeException a) -> IO ()     worker sem inqVar outqVar =       forever $ do         job <- atomically $ readTChan inqVar-        -- mask here, as we need to ensure that the thread which contains the-        -- release action is spawned. Otherwise, there is the chance that an-        -- async exception is thrown between the semaphore being taken and the-        -- thread being spawned.+        -- mask so that the fork happens atomically with the acquire.         mask_ $ do-          waitOnSemaphore sem+          -- waitOnSemaphore is interruptible under mask_+          tok <- waitOnSemaphore sem           void $ forkIOWithUnmask $ \unmask -> do-            res <- try (unmask job)-            releaseSemaphore sem 1+            res <- try (unmask job) `finally` releaseSemaphoreToken tok             atomically $ writeTChan outqVar res         -- Try to give GHC enough time to compute the module graph and then         -- request some additional capabilities if it can make use of them. The@@ -291,17 +299,39 @@   UseSem n ->     case mcompiler of       Just compiler-        | jsemSupported compiler ->+        | jsemSupported compiler+        , isJsemCompatible compiler ->             newSemaphoreJobControl verbosity (capJobs n)+        | jsemSupported compiler ->+            do+              warn verbosity $+                "Semaphore version mismatch (cabal-install uses v"+                  ++ show (getSemaphoreProtocolVersion semaphoreVersion)+                  ++ ", but the selected GHC reports "+                  ++ maybe "no version (assumed v1)" (\v -> "v" ++ show v) (jsemVersion compiler)+                  ++ "); not using -jsem, GHC will be invoked without semaphore-based parallelism."+              newParallelJobControl (capJobs n)         | otherwise ->             do-              warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."+              warn verbosity $+                "-jsem is not supported by the selected compiler; falling back to -j"+                  ++ show (capJobs n)+                  ++ "."               newParallelJobControl (capJobs n)       Nothing ->         -- Don't warn in the Nothing case, as there isn't really a "selected" compiler.         newParallelJobControl (capJobs n)   where     capJobs n = min (fromMaybe maxBound numJobsCap) n++-- | Check if the compiler's semaphore version is compatible with ours,+-- per 'versionsAreCompatible'. A compiler that doesn't report a+-- @"Semaphore version"@ field is treated as v1.+isJsemCompatible :: Compiler -> Bool+isJsemCompatible compiler =+  versionsAreCompatible (SemaphoreProtocolVersion v) semaphoreVersion+  where+    v = fromMaybe 1 (jsemVersion compiler)  withJobControl :: IO (JobControl IO a) -> (JobControl IO a -> IO b) -> IO b withJobControl mkJC = bracket mkJC cleanupJobControl
src/Distribution/Client/List.hs view
@@ -31,10 +31,7 @@   , packageName   , packageVersion   )-import Distribution.PackageDescription-  ( PackageFlag (..)-  , unFlagName-  )+import Distribution.PackageDescription (PackageFlag (..), repoKind, repoLocation, sourceRepos, unFlagName) import qualified Distribution.PackageDescription as Source import Distribution.PackageDescription.Configuration   ( flattenPackageDescription@@ -157,9 +154,7 @@    let sourcePkgIndex = packageIndex sourcePkgDb       prefs name =-        fromMaybe-          anyVersion-          (Map.lookup name (packagePreferences sourcePkgDb))+        Map.findWithDefault anyVersion name (packagePreferences sourcePkgDb)        pkgsInfoMatching         :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]@@ -269,9 +264,7 @@     sourcePkgDb <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name =-          fromMaybe-            anyVersion-            (Map.lookup name (packagePreferences sourcePkgDb))+          Map.findWithDefault anyVersion name (packagePreferences sourcePkgDb)      -- Users may specify names of packages that are only installed, not     -- just available source packages, so we must resolve targets using@@ -318,7 +311,7 @@         installedPkgIndex         sourcePkgIndex         (NamedPackage name props)-          | null (selectedInstalledPkgs) && null (selectedSourcePkgs) =+          | null selectedInstalledPkgs && null selectedSourcePkgs =               Left $ GatherPkgInfo name (simplifyVersionRange verConstraint)           | otherwise =               Right $@@ -611,14 +604,7 @@             installed       , bugReports = maybe mempty Source.bugReports source       , sourceRepo =-          fromMaybe mempty-            . join-            . fmap-              ( uncons Nothing Source.repoLocation-                  . sortBy (comparing Source.repoKind)-                  . Source.sourceRepos-              )-            $ source+          fromMaybe mempty $ (uncons Nothing repoLocation . sortBy (comparing repoKind) . sourceRepos) =<< source       , -- TODO: installed package info is missing synopsis         synopsis = maybe mempty Source.synopsis source       , description =@@ -654,11 +640,7 @@             source             (map InstalledDependency . Installed.depends)             installed-      , haddockHtml =-          fromMaybe ""-            . join-            . fmap (listToMaybe . Installed.haddockHTMLs)-            $ installed+      , haddockHtml = fromMaybe "" $ (listToMaybe . Installed.haddockHTMLs) =<< installed       , haveTarball = False       }   where
src/Distribution/Client/Main.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  -- | -- Module      :  Main@@ -32,6 +33,7 @@   , InitFlags (initHcPath, initVerbosity)   , InstallFlags (..)   , ListFlags (..)+  , RepoContext (..)   , ReportFlags (..)   , UploadFlags (..)   , UserConfigFlags (..)@@ -99,6 +101,7 @@   ( SavedConfig (..)   , createDefaultConfigFile   , defaultConfigFile+  , defaultUserInstall   , getConfigFilePath   , loadConfig   , userConfigDiff@@ -109,7 +112,8 @@   , list   ) import Distribution.Client.SetupWrapper-  ( SetupScriptOptions (..)+  ( SetupRunnerArgs (NotInLibrary)+  , SetupScriptOptions (..)   , defaultSetupScriptOptions   , setupWrapper   )@@ -151,10 +155,6 @@ import Distribution.Client.Init (initCmd) import Distribution.Client.Manpage (manpageCmd) import Distribution.Client.ManpageFlags (ManpageFlags (..))-import Distribution.Client.Nix-  ( nixInstantiate-  , nixShell-  ) import Distribution.Client.Reconfigure (Check (..), reconfigure) import Distribution.Client.Run (run, splitRunArgs) import Distribution.Client.Sandbox@@ -186,7 +186,6 @@  import Distribution.Client.Errors import Distribution.Compat.ResponseFile-import qualified Distribution.Make as Make import Distribution.PackageDescription.PrettyPrint   ( writeGenericPackageDescription   )@@ -228,13 +227,17 @@ import Distribution.Simple.Program.Db (reconfigurePrograms) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils-  ( cabalGitInfo+  ( VerboseException+  , cabalCompilerInfo+  , cabalGitInfo   , cabalVersion   , createDirectoryIfMissingVerbose+  , die'   , dieNoVerbosity   , dieWithException   , findPackageDesc   , info+  , isUserException   , notice   , topHandler   , tryFindPackageDesc@@ -249,7 +252,12 @@   , (</>)   ) import Distribution.Verbosity as Verbosity-  ( normal+  ( VerbosityFlags+  , defaultVerbosityHandles+  , mkVerbosity+  , normal+  , verbosityFlags+  , verbosityHandles   ) import Distribution.Version   ( Version@@ -259,6 +267,7 @@  import Control.Exception (AssertionFailed, assert, try) import Data.Monoid (Any (..))+import Distribution.Client.Types import System.Directory   ( doesFileExist   , withCurrentDirectory@@ -314,7 +323,7 @@   -- for more information.   let (args0, args1) = break (== "--") args -  mainWorker =<< (++ args1) <$> expandResponse args0+  mainWorker . (++ args1) =<< expandResponse args0  -- | Check whether assertions are enabled and print a warning in that case. warnIfAssertionsAreEnabled :: IO ()@@ -336,7 +345,7 @@ -- into IO actions for execution. mainWorker :: [String] -> IO () mainWorker args = do-  topHandler $ do+  topHandler (isUserException (Proxy @(VerboseException CabalInstallException))) $ do     command <- commandsRunWithFallback (globalCommand commands) commands delegateToExternal args     case command of       CommandHelp help -> printGlobalHelp help@@ -347,6 +356,8 @@           _             | fromFlagOrDefault False (globalVersion globalFlags) ->                 printVersion+            | fromFlagOrDefault False (globalFullVersion globalFlags) ->+                printFullVersion             | fromFlagOrDefault False (globalNumericVersion globalFlags) ->                 printNumericVersion           CommandHelp help -> printCommandHelp help@@ -376,7 +387,8 @@       -- we rely on cabal's implementation of findProgramOnSearchPath not following       -- symlinks here. If that ever happens, then the argv[0] of the called executable       -- will be different from the intended one and will break tools that work by reading it.-      mCommand <- findProgramOnSearchPath normal defaultProgramSearchPath ("cabal-" <> name)+      let verb = mkVerbosity defaultVerbosityHandles normal+      mCommand <- findProgramOnSearchPath verb defaultProgramSearchPath ("cabal-" <> name)       case mCommand of         Just (exec, _) -> return (CommandReadyToGo $ \_ -> callExternal exec cmdArgs)         Nothing -> defaultCommandFallback commands' name cmdArgs@@ -419,14 +431,28 @@       putStrLn $         "cabal-install version "           ++ display cabalInstallVersion-          ++ " "-          ++ cabalInstallGitInfo           ++ "\ncompiled using version "           ++ display cabalVersion           ++ " of the Cabal library "+    printFullVersion =+      putStrLn $+        "cabal-install version "+          ++ display cabalInstallVersion+          ++ cabalInstallGitInfo'+          ++ "\ncompiled using version "+          ++ display cabalVersion+          ++ " of the Cabal library "           ++ cabalGitInfo'+          ++ "\nwith "+          -- it's impossible for cabal-install to have been built with a different compiler+          -- from Cabal, so just reuse its info+          ++ cabalCompilerInfo       where+        cabalInstallGitInfo'+          | null cabalInstallGitInfo = ""+          | otherwise = ' ' : cabalInstallGitInfo         cabalGitInfo'+          | null cabalGitInfo && null cabalInstallGitInfo = ""           | cabalGitInfo == cabalInstallGitInfo = "(in-tree)"           | otherwise = cabalGitInfo @@ -494,7 +520,7 @@   -> (flags -> [String] -> action)   -> CommandSpec action regularCmd ui action =-  CommandSpec ui ((flip commandAddAction) action) NormalCommand+  CommandSpec ui (`commandAddAction` action) NormalCommand  hiddenCmd   :: CommandUI flags@@ -512,7 +538,7 @@   -> (flags -> CommonSetupFlags)   -> CommandSpec Action wrapperCmd ui getCommonFlags =-  CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand+  CommandSpec ui (`wrapperAction` getCommonFlags) NormalCommand  wrapperAction   :: Monoid flags@@ -526,7 +552,10 @@       }     $ \flags extraArgs globalFlags -> do       let common = getCommonFlags flags-          verbosity = fromFlagOrDefault normal $ setupVerbosity common+          verbosity =+            mkVerbosity defaultVerbosityHandles $+              fromFlagOrDefault normal $+                setupVerbosity common           mbWorkDir = flagToMaybe $ setupWorkingDir common       load <- try (loadConfigOrSandboxConfig verbosity globalFlags)       let config = either (\(SomeException _) -> mempty) id load@@ -544,6 +573,7 @@         getCommonFlags         (const (return flags))         (const extraArgs)+        NotInLibrary  configureAction   :: (ConfigFlags, ConfigExFlags)@@ -551,46 +581,51 @@   -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let common = configCommonFlags configFlags-      verbosity = fromFlagOrDefault normal $ setupVerbosity common+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal $+            setupVerbosity common+   config <-     updateInstallDirs (configUserInstall configFlags)       <$> loadConfigOrSandboxConfig verbosity globalFlags   distPref <- getSymbolicPath <$> findSavedDistPref config (setupDistPref common)-  nixInstantiate verbosity distPref True globalFlags config-  nixShell verbosity distPref globalFlags config $ do-    let configFlags' = savedConfigureFlags config `mappend` configFlags-        configExFlags' = savedConfigureExFlags config `mappend` configExFlags-        globalFlags' = savedGlobalFlags config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAuxEx configFlags' -    writeConfigFlags verbosity distPref (configFlags', configExFlags')+  let configFlags' = savedConfigureFlags config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, progdb) <- configCompilerAuxEx (verbosityHandles verbosity) configFlags' -    -- What package database(s) to use-    let packageDBs :: PackageDBStack-        packageDBs =-          interpretPackageDbFlags-            (fromFlag (configUserInstall configFlags'))-            (configPackageDBs configFlags')+  writeConfigFlags verbosity distPref (configFlags', configExFlags') -    withRepoContext verbosity globalFlags' $ \repoContext ->-      configure-        verbosity-        (interpretPackageDBStack Nothing packageDBs)-        repoContext-        comp-        platform-        progdb-        configFlags'-        configExFlags'-        extraArgs+  -- What package database(s) to use+  let packageDBs :: PackageDBStack+      packageDBs =+        interpretPackageDbFlags+          (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags'))+          (configPackageDBs configFlags') +  withRepoContext verbosity globalFlags' $ \repoContext ->+    configure+      verbosity+      (interpretPackageDBStack Nothing packageDBs)+      repoContext+      comp+      platform+      progdb+      configFlags'+      configExFlags'+      extraArgs+ reconfigureAction   :: (ConfigFlags, ConfigExFlags)   -> [String]   -> Action reconfigureAction flags@(configFlags, _) _ globalFlags = do   let common = configCommonFlags configFlags-      verbosity = fromFlagOrDefault normal (setupVerbosity common)+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal (setupVerbosity common)   config <-     updateInstallDirs (configUserInstall configFlags)       <$> loadConfigOrSandboxConfig verbosity globalFlags@@ -606,7 +641,6 @@           message =             "flags changed: "               ++ unwords (commandShowOptions configureExCommand flags)-  nixInstantiate verbosity (getSymbolicPath distPref) True globalFlags config   _ <-     reconfigure       configureAction@@ -622,7 +656,10 @@ buildAction :: BuildFlags -> [String] -> Action buildAction buildFlags extraArgs globalFlags = do   let common = buildCommonFlags buildFlags-      verbosity = fromFlagOrDefault normal $ setupVerbosity common+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal $+            setupVerbosity common   config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (setupDistPref common)   -- Calls 'configureAction' to do the real work, so nothing special has to be@@ -637,8 +674,7 @@       []       globalFlags       config-  nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-    build verbosity config' distPref buildFlags extraArgs+  build verbosity config' distPref buildFlags extraArgs  -- | Actually do the work of building the package. This is separate from -- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke@@ -653,6 +689,7 @@     buildCommonFlags     (return . mkBuildFlags)     (const extraArgs)+    NotInLibrary   where     progDb = defaultProgramDb     setupOptions = defaultSetupScriptOptions{useDistPref = distPref}@@ -663,7 +700,7 @@       buildFlags         { buildCommonFlags =             commonFlags-              { setupVerbosity = toFlag verbosity+              { setupVerbosity = toFlag $ verbosityFlags verbosity               , setupDistPref = toFlag distPref               }         }@@ -701,7 +738,10 @@ replAction :: ReplFlags -> [String] -> Action replAction replFlags extraArgs globalFlags = do   let common = replCommonFlags replFlags-      verbosity = fromFlagOrDefault normal $ setupVerbosity common+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal $+            setupVerbosity common   config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (setupDistPref common)   pkgDesc <- findPackageDesc Nothing@@ -732,20 +772,20 @@             replFlags               { replCommonFlags =                   commonFlags-                    { setupVerbosity = toFlag verbosity+                    { setupVerbosity = toFlag $ verbosityFlags verbosity                     , setupDistPref = toFlag distPref                     }               } -      nixShell verbosity (getSymbolicPath distPref) globalFlags config $-        setupWrapper-          verbosity-          setupOptions-          Nothing-          (Cabal.replCommand progDb)-          Cabal.replCommonFlags-          (const (return replFlags'))-          (const extraArgs)+      setupWrapper+        verbosity+        setupOptions+        Nothing+        (Cabal.replCommand progDb)+        Cabal.replCommonFlags+        (const (return replFlags'))+        (const extraArgs)+        NotInLibrary      -- No .cabal file in the current directory: just start the REPL (possibly     -- using the sandbox package DB).@@ -758,14 +798,14 @@           (replProgramPaths replFlags)           (replProgramArgs replFlags)           programDb-      nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-        startInterpreter-          verbosity-          programDb'-          comp-          platform-          (configPackageDB' configFlags) +      startInterpreter+        verbosity+        programDb'+        comp+        platform+        (configPackageDB' configFlags)+   either (const onNoPkgDesc) (const onPkgDesc) pkgDesc  installAction@@ -781,7 +821,9 @@ installAction (configFlags, _, installFlags, _, _, _) _ globalFlags   | fromFlagOrDefault False (installOnly installFlags) = do       let common = configCommonFlags configFlags-          verb = fromFlagOrDefault normal (setupVerbosity common)+          verb =+            mkVerbosity defaultVerbosityHandles $+              fromFlagOrDefault normal (setupVerbosity common)       config <- loadConfigOrSandboxConfig verb globalFlags       dist <- findSavedDistPref config (setupDistPref common)       let setupOpts = defaultSetupScriptOptions{useDistPref = dist}@@ -793,6 +835,7 @@         (const common)         (const (return (mempty, mempty, mempty, mempty, mempty, mempty)))         (const [])+        NotInLibrary installAction   ( configFlags     , configExFlags@@ -804,7 +847,10 @@   extraArgs   globalFlags = do     let common = configCommonFlags configFlags-        verb = fromFlagOrDefault normal $ setupVerbosity common+        verb =+          mkVerbosity defaultVerbosityHandles $+            fromFlagOrDefault normal $+              setupVerbosity common     config <-       updateInstallDirs (configUserInstall configFlags)         <$> loadConfigOrSandboxConfig verb globalFlags@@ -894,7 +940,9 @@   -> GlobalFlags   -> IO () testAction (buildFlags, testFlags) extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (setupVerbosity $ buildCommonFlags buildFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal (setupVerbosity $ buildCommonFlags buildFlags)   config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (setupDistPref $ testCommonFlags testFlags)   let buildFlags' =@@ -925,42 +973,44 @@       []       globalFlags       config-  nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-    let setupOptions = defaultSetupScriptOptions{useDistPref = distPref}-        testFlags' =-          testFlags-            { testCommonFlags =-                (testCommonFlags testFlags){setupDistPref = toFlag distPref}-            }-        mbWorkDir = flagToMaybe $ testWorkingDir testFlags -    -- The package was just configured, so the LBI must be available.-    names <--      componentNamesFromLBI-        verbosity-        mbWorkDir-        distPref-        "test suites"-        (\c -> case c of LBI.CTest{} -> True; _ -> False)-    let extraArgs'-          | null extraArgs = case names of-              ComponentNamesUnknown -> []-              ComponentNames names' ->-                [ Make.unUnqualComponentName name-                | LBI.CTestName name <- names'-                ]-          | otherwise = extraArgs+  let setupOptions = defaultSetupScriptOptions{useDistPref = distPref}+      testFlags' =+        testFlags+          { testCommonFlags =+              (testCommonFlags testFlags){setupDistPref = toFlag distPref}+          }+      mbWorkDir = flagToMaybe $ testWorkingDir testFlags -    build verbosity config distPref buildFlags' extraArgs'-    setupWrapper+  -- The package was just configured, so the LBI must be available.+  names <-+    componentNamesFromLBI       verbosity-      setupOptions-      Nothing-      Cabal.testCommand-      Cabal.testCommonFlags-      (const (return testFlags'))-      (const extraArgs')+      mbWorkDir+      distPref+      "test suites"+      (\case LBI.CTest{} -> True; _ -> False) +  let extraArgs'+        | null extraArgs = case names of+            ComponentNamesUnknown -> []+            ComponentNames names' ->+              [ Make.unUnqualComponentName name+              | LBI.CTestName name <- names'+              ]+        | otherwise = extraArgs++  build verbosity config distPref buildFlags' extraArgs'+  setupWrapper+    verbosity+    setupOptions+    Nothing+    Cabal.testCommand+    Cabal.testCommonFlags+    (const (return testFlags'))+    (const extraArgs')+    NotInLibrary+ data ComponentNames   = ComponentNamesUnknown   | ComponentNames [LBI.ComponentName]@@ -981,7 +1031,7 @@       -- Note: the build config could have been generated by a custom setup       -- script built against a different Cabal version, so it's crucial that       -- we ignore the bad version error here.-      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown+      ConfigStateFileBadVersion{} -> return ComponentNamesUnknown       _ -> dieWithException verbosity $ ConfigStateFileException (show err)     Right lbi -> do       let pkgDescr = LBI.localPkgDescr lbi@@ -997,7 +1047,7 @@               ++ targetsDescr               ++ "."           exitSuccess -- See #3215.-        else return $! (ComponentNames names)+        else return $! ComponentNames names  benchmarkAction   :: (BuildFlags, BenchmarkFlags)@@ -1009,9 +1059,10 @@   extraArgs   globalFlags = do     let verbosity =-          fromFlagOrDefault-            normal-            (setupVerbosity $ buildCommonFlags buildFlags)+          mkVerbosity defaultVerbosityHandles $+            fromFlagOrDefault+              normal+              (setupVerbosity $ buildCommonFlags buildFlags)      config <- loadConfigOrSandboxConfig verbosity globalFlags     distPref <- findSavedDistPref config (setupDistPref $ benchmarkCommonFlags benchmarkFlags)@@ -1044,48 +1095,53 @@         []         globalFlags         config-    nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-      let setupOptions = defaultSetupScriptOptions{useDistPref = distPref}-          benchmarkFlags' =-            benchmarkFlags-              { benchmarkCommonFlags =-                  (benchmarkCommonFlags benchmarkFlags)-                    { setupDistPref = toFlag distPref-                    }-              }-          mbWorkDir = flagToMaybe $ benchmarkWorkingDir benchmarkFlags -      -- The package was just configured, so the LBI must be available.-      names <--        componentNamesFromLBI-          verbosity-          mbWorkDir-          distPref-          "benchmarks"-          (\c -> case c of LBI.CBench{} -> True; _ -> False)-      let extraArgs'-            | null extraArgs = case names of-                ComponentNamesUnknown -> []-                ComponentNames names' ->-                  [ Make.unUnqualComponentName name-                  | LBI.CBenchName name <- names'-                  ]-            | otherwise = extraArgs+    let setupOptions = defaultSetupScriptOptions{useDistPref = distPref}+        benchmarkFlags' =+          benchmarkFlags+            { benchmarkCommonFlags =+                (benchmarkCommonFlags benchmarkFlags)+                  { setupDistPref = toFlag distPref+                  }+            }+        mbWorkDir = flagToMaybe $ benchmarkWorkingDir benchmarkFlags -      build verbosity config' distPref buildFlags' extraArgs'-      setupWrapper+    -- The package was just configured, so the LBI must be available.+    names <-+      componentNamesFromLBI         verbosity-        setupOptions-        Nothing-        Cabal.benchmarkCommand-        Cabal.benchmarkCommonFlags-        (const (return benchmarkFlags'))-        (const extraArgs')+        mbWorkDir+        distPref+        "benchmarks"+        (\case LBI.CBench{} -> True; _ -> False) +    let extraArgs'+          | null extraArgs = case names of+              ComponentNamesUnknown -> []+              ComponentNames names' ->+                [ Make.unUnqualComponentName name+                | LBI.CBenchName name <- names'+                ]+          | otherwise = extraArgs++    build verbosity config' distPref buildFlags' extraArgs'+    setupWrapper+      verbosity+      setupOptions+      Nothing+      Cabal.benchmarkCommand+      Cabal.benchmarkCommonFlags+      (const (return benchmarkFlags'))+      (const extraArgs')+      NotInLibrary+ haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do   let common = haddockCommonFlags haddockFlags-      verbosity = fromFlag $ setupVerbosity common+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag $+            setupVerbosity common   config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (setupDistPref common)   config' <-@@ -1098,41 +1154,47 @@       []       globalFlags       config+   let mbWorkDir = flagToMaybe $ setupWorkingDir common-  nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-    let haddockFlags' =-          defaultHaddockFlags-            `mappend` savedHaddockFlags config'-            `mappend` haddockFlags-              { haddockCommonFlags =-                  (haddockCommonFlags haddockFlags)-                    { setupDistPref = toFlag distPref-                    }-              }-        setupScriptOptions =-          defaultSetupScriptOptions-            { useDistPref = distPref+      haddockFlags' =+        defaultHaddockFlags+          `mappend` savedHaddockFlags config'+          `mappend` haddockFlags+            { haddockCommonFlags =+                (haddockCommonFlags haddockFlags)+                  { setupDistPref = toFlag distPref+                  }             }-    setupWrapper-      verbosity-      setupScriptOptions-      Nothing-      haddockCommand-      haddockCommonFlags-      (const (return haddockFlags'))-      (const extraArgs)-    when (haddockForHackage haddockFlags == Flag ForHackage) $ do-      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref)-      let dest = getSymbolicPath distPref </> name <.> "tar.gz"-          name = display (packageId pkg) ++ "-docs"-          docDir = getSymbolicPath distPref </> "doc" </> "html"-      createTarGzFile dest docDir name-      notice verbosity $ "Documentation tarball created: " ++ dest+      setupScriptOptions =+        defaultSetupScriptOptions+          { useDistPref = distPref+          } +  setupWrapper+    verbosity+    setupScriptOptions+    Nothing+    haddockCommand+    haddockCommonFlags+    (const (return haddockFlags'))+    (const extraArgs)+    NotInLibrary++  when (haddockForHackage haddockFlags == Flag ForHackage) $ do+    pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref)+    let dest = getSymbolicPath distPref </> name <.> "tar.gz"+        name = display (packageId pkg) ++ "-docs"+        docDir = getSymbolicPath distPref </> "doc" </> "html"+    createTarGzFile dest docDir name+    notice verbosity $ "Documentation tarball created: " ++ dest+ cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do   let common = cleanCommonFlags cleanFlags-      verbosity = fromFlagOrDefault normal $ setupVerbosity common+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal $+            setupVerbosity common   load <- try (loadConfigOrSandboxConfig verbosity globalFlags)   let config = either (\(SomeException _) -> mempty) id load   distPref <- findSavedDistPref config $ setupDistPref common@@ -1156,10 +1218,13 @@     cleanCommonFlags     (const (return cleanFlags'))     (const extraArgs)+    NotInLibrary  listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do-  let verbosity = fromFlag (listVerbosity listFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (listVerbosity listFlags)   config <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags' = savedConfigureFlags config       configFlags =@@ -1187,7 +1252,9 @@  infoAction :: InfoFlags -> [String] -> Action infoAction infoFlags extraArgs globalFlags = do-  let verbosity = fromFlag (infoVerbosity infoFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs   config <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags' = savedConfigureFlags config@@ -1198,7 +1265,7 @@                 `mappend` infoPackageDBs infoFlags           }       globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, _, progdb) <- configCompilerAuxEx configFlags+  (comp, _, progdb) <- configCompilerAuxEx defaultVerbosityHandles configFlags   withRepoContext verbosity globalFlags' $ \repoContext ->     List.info       verbosity@@ -1212,7 +1279,9 @@  fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do-  let verbosity = fromFlag (fetchVerbosity fetchFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (fetchVerbosity fetchFlags)   targets <- readUserTargets verbosity extraArgs   config <- loadConfig verbosity (globalConfigFile globalFlags)   let configFlags = savedConfigureFlags config@@ -1232,45 +1301,45 @@  freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (freezeVerbosity freezeFlags)   config <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config NoFlag-  nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-    let configFlags = savedConfigureFlags config-        globalFlags' = savedGlobalFlags config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAux' configFlags+  let configFlags = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags -    withRepoContext verbosity globalFlags' $ \repoContext ->-      freeze-        verbosity-        (interpretPackageDBStack Nothing (configPackageDB' configFlags))-        repoContext-        comp-        platform-        progdb-        globalFlags'-        freezeFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    freeze+      verbosity+      (interpretPackageDBStack Nothing (configPackageDB' configFlags))+      repoContext+      comp+      platform+      progdb+      globalFlags'+      freezeFlags  genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () genBoundsAction freezeFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (freezeVerbosity freezeFlags)   config <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config NoFlag-  nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-    let configFlags = savedConfigureFlags config-        globalFlags' = savedGlobalFlags config `mappend` globalFlags-    (comp, platform, progdb) <- configCompilerAux' configFlags+  let configFlags = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags -    withRepoContext verbosity globalFlags' $ \repoContext ->-      genBounds-        verbosity-        (interpretPackageDBStack Nothing (configPackageDB' configFlags))-        repoContext-        comp-        platform-        progdb-        globalFlags'-        freezeFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    genBounds+      verbosity+      (interpretPackageDBStack Nothing (configPackageDB' configFlags))+      repoContext+      comp+      platform+      progdb+      globalFlags'+      freezeFlags  uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do@@ -1278,6 +1347,7 @@   let uploadFlags' = savedUploadFlags config `mappend` uploadFlags       globalFlags' = savedGlobalFlags config `mappend` globalFlags       tarfiles = extraArgs+      chosenRepo = flagToMaybe $ uploadRepoName uploadFlags'   when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $     dieWithException verbosity UploadAction   checkTarFiles extraArgs@@ -1290,6 +1360,7 @@             (simpleProgramInvocation xs xss)       _ -> pure $ flagToMaybe $ uploadPassword uploadFlags'   withRepoContext verbosity globalFlags' $ \repoContext -> do+    filteredRepoContext <- chooseRepo verbosity repoContext (unRepoName <$> chosenRepo)     if fromFlag (uploadDoc uploadFlags')       then do         when (length tarfiles > 1) $@@ -1297,7 +1368,7 @@         tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles         Upload.uploadDoc           verbosity-          repoContext+          filteredRepoContext           (flagToMaybe $ uploadToken uploadFlags')           (flagToMaybe $ uploadUsername uploadFlags')           maybe_password@@ -1306,14 +1377,16 @@       else do         Upload.upload           verbosity-          repoContext+          filteredRepoContext           (flagToMaybe $ uploadToken uploadFlags')           (flagToMaybe $ uploadUsername uploadFlags')           maybe_password           (fromFlag (uploadCandidate uploadFlags'))           tarfiles   where-    verbosity = fromFlag (uploadVerbosity uploadFlags)+    verbosity =+      mkVerbosity defaultVerbosityHandles $+        fromFlag (uploadVerbosity uploadFlags)     checkTarFiles tarfiles       | not (null otherFiles) =           dieWithException verbosity $ UploadActionOnlyArchives otherFiles@@ -1348,16 +1421,16 @@ checkAction :: CheckFlags -> [String] -> Action checkAction checkFlags extraArgs _globalFlags = do   let verbosityFlag = checkVerbosity checkFlags-      verbosity = fromFlag verbosityFlag+      verbosity = mkVerbosity defaultVerbosityHandles $ fromFlag verbosityFlag   unless (null extraArgs) $     dieWithException verbosity $       CheckAction extraArgs-  allOk <- Check.check (fromFlag verbosityFlag) (checkIgnore checkFlags)+  allOk <- Check.check (mkVerbosity defaultVerbosityHandles $ fromFlag verbosityFlag) (checkIgnore checkFlags)   unless allOk exitFailure -formatAction :: Flag Verbosity -> [String] -> Action+formatAction :: Flag VerbosityFlags -> [String] -> Action formatAction verbosityFlag extraArgs _globalFlags = do-  let verbosity = fromFlag verbosityFlag+  let verbosity = mkVerbosity defaultVerbosityHandles $ fromFlag verbosityFlag   warn verbosity "This command is not a full formatter yet"   path <- case extraArgs of     [] -> relativeSymbolicPath <$> tryFindPackageDesc verbosity Nothing@@ -1368,18 +1441,21 @@  reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do-  let verbosity = fromFlag (reportVerbosity reportFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (reportVerbosity reportFlags)   unless (null extraArgs) $     dieWithException verbosity $       ReportAction extraArgs   config <- loadConfig verbosity (globalConfigFile globalFlags)   let globalFlags' = savedGlobalFlags config `mappend` globalFlags       reportFlags' = savedReportFlags config `mappend` reportFlags--  withRepoContext verbosity globalFlags' $ \repoContext ->+      chosenRepo = flagToMaybe $ reportRepoName reportFlags'+  withRepoContext verbosity globalFlags' $ \repoContext -> do+    filteredRepoContext <- chooseRepo verbosity repoContext (unRepoName <$> chosenRepo)     Upload.report       verbosity-      repoContext+      filteredRepoContext       (flagToMaybe $ reportToken reportFlags')       (flagToMaybe $ reportUsername reportFlags')       (flagToMaybe $ reportPassword reportFlags')@@ -1387,7 +1463,10 @@ runAction :: BuildFlags -> [String] -> Action runAction buildFlags extraArgs globalFlags = do   let common = buildCommonFlags buildFlags-      verbosity = fromFlagOrDefault normal $ setupVerbosity common+      verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlagOrDefault normal $+            setupVerbosity common   config <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config $ setupDistPref common   config' <-@@ -1401,23 +1480,26 @@       globalFlags       config   let mbWorkDir = flagToMaybe $ setupWorkingDir common-  nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do-    lbi <- getPersistBuildConfig mbWorkDir distPref-    (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs+  lbi <- getPersistBuildConfig mbWorkDir distPref+  (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs -    build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]-    run verbosity lbi exe exeArgs+  build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]+  run verbosity lbi exe exeArgs  getAction :: GetFlags -> [String] -> Action getAction getFlags extraArgs globalFlags = do-  let verbosity = fromFlag (getVerbosity getFlags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs   config <- loadConfigOrSandboxConfig verbosity globalFlags   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->+      chosenRepo = flagToMaybe $ getRepoName getFlags+  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> do+    filteredRepoContext <- chooseRepo verbosity repoContext (unRepoName <$> chosenRepo)     get       verbosity-      repoContext+      filteredRepoContext       globalFlags'       getFlags       targets@@ -1455,19 +1537,23 @@           progdb           initFlags' -    verbosity = fromFlag (initVerbosity initFlags)+    verbosity =+      mkVerbosity defaultVerbosityHandles $+        fromFlag (initVerbosity initFlags)     compFlags = mempty{configHcPath = initHcPath initFlags}  userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do-  let verbosity = fromFlag (userConfigVerbosity ucflags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (userConfigVerbosity ucflags)       frc = fromFlag (userConfigForce ucflags)       extraLines = fromFlag (userConfigAppendLines ucflags)   case extraArgs of     ("init" : _) -> do-      path <- configFile+      path <- getConfigFilePath verbosity (globalConfigFile globalFlags)       fileExists <- doesFileExist path-      if (not fileExists || (fileExists && frc))+      if not fileExists || (fileExists && frc)         then void $ createDefaultConfigFile verbosity extraLines path         else dieWithException verbosity $ UserConfigAction path     ("diff" : _) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines@@ -1475,8 +1561,6 @@     -- Error handling.     [] -> dieWithException verbosity SpecifySubcommand     _ -> dieWithException verbosity $ UnknownUserConfigSubcommand extraArgs-  where-    configFile = getConfigFilePath (globalConfigFile globalFlags)  -- | Used as an entry point when cabal-install needs to invoke itself -- as a setup script. This can happen e.g. when doing parallel builds.@@ -1488,14 +1572,17 @@         Configure ->           Simple.defaultMainWithSetupHooksArgs             Simple.autoconfSetupHooks+            defaultVerbosityHandles             args-        Make -> Make.defaultMainArgs args+        Make -> error "actAsSetupAction Main"         Hooks -> error "actAsSetupAction Hooks"         Custom -> error "actAsSetupAction Custom"  manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action manpageAction commands flags extraArgs _ = do-  let verbosity = fromFlag (manpageVerbosity flags)+  let verbosity =+        mkVerbosity defaultVerbosityHandles $+          fromFlag (manpageVerbosity flags)   unless (null extraArgs) $     dieWithException verbosity $       ManpageAction extraArgs@@ -1505,3 +1592,31 @@           then dropExtension pname           else pname   manpageCmd cabalCmd commands flags++chooseRepo :: Verbosity -> RepoContext -> Maybe String -> IO RepoContext+chooseRepo verbosity ctx mrepo = do+  let repos = repoContextRepos ctx+  let remoteRepositories = filter isRepoRemote repos+  filtered <- case mrepo of+    Just name -> case find (\r -> name == (unRepoName . repoName) r) repos of+      Just found -> return [found]+      Nothing ->+        die' verbosity $+          mconcat+            [ "Cannot find chosen repository "+            , name+            , "."+            , " Available repositories are: "+            , intercalate ", " (fmap (unRepoName . repoName) (repoContextRepos ctx))+            ]+    Nothing -> return remoteRepositories+  if length filtered > 1+    then+      die'+        verbosity+        $ mconcat+          [ "Cannot determine a specific hackage repository. Please choose one with --repository-name."+          , " Available repositories are: "+          , intercalate ", " (fmap (unRepoName . repoName) (repoContextRepos ctx))+          ]+    else pure ctx{repoContextRepos = filtered}
src/Distribution/Client/Manpage.hs view
@@ -37,6 +37,7 @@   , rawSystemProcAction   , rawSystemStdInOut   )+import Distribution.Verbosity import System.Environment (lookupEnv) import System.IO (hClose, hPutStr) import qualified System.Process as Process@@ -52,7 +53,7 @@ -- | A list of files that should be documented in the manual page. files :: [FileInfo] files =-  [ (FileInfo "~/.config/cabal/config" "The defaults that can be overridden with command-line options.")+  [ FileInfo "~/.config/cabal/config" "The defaults that can be overridden with command-line options."   ]  manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()@@ -102,7 +103,10 @@   where     contents :: String     contents = manpage pname commands-    verbosity = fromFlag $ manpageVerbosity flags+    verbosity =+      mkVerbosity defaultVerbosityHandles $+        fromFlag $+          manpageVerbosity flags  -- | Produces a manual page with @troff@ markup. manpage :: String -> [CommandSpec a] -> String@@ -150,7 +154,7 @@  commandSynopsisLines :: String -> CommandSpec action -> [String] commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =-  [ ".B " ++ pname ++ " " ++ (commandName ui)+  [ ".B " ++ pname ++ " " ++ commandName ui   , "- " ++ commandSynopsis ui   , ".br"   ]@@ -158,7 +162,7 @@  commandDetailsLines :: String -> CommandSpec action -> [String] commandDetailsLines pname (CommandSpec ui _ NormalCommand) =-  [ ".B " ++ pname ++ " " ++ (commandName ui)+  [ ".B " ++ pname ++ " " ++ commandName ui   , ""   , commandUsage ui pname   , ""
src/Distribution/Client/ManpageFlags.hs view
@@ -10,10 +10,10 @@  import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) import Distribution.Simple.Setup (Flag, optionVerbosity, toFlag, trueArg)-import Distribution.Verbosity (normal)+import Distribution.Verbosity (VerbosityFlags, normal)  data ManpageFlags = ManpageFlags-  { manpageVerbosity :: Flag Verbosity+  { manpageVerbosity :: Flag VerbosityFlags   , manpageRaw :: Flag Bool   }   deriving (Eq, Show, Generic)
− src/Distribution/Client/Nix.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE LambdaCase #-}--module Distribution.Client.Nix-  ( findNixExpr-  , inNixShell-  , nixInstantiate-  , nixShell-  ) where--import Distribution.Client.Compat.Prelude--import Control.Exception (bracket)-import System.Directory-  ( canonicalizePath-  , createDirectoryIfMissing-  , doesDirectoryExist-  , doesFileExist-  , removeDirectoryRecursive-  , removeFile-  )-import System.Environment (getArgs, getExecutablePath)-import System.FilePath-  ( replaceExtension-  , takeDirectory-  , takeFileName-  , (</>)-  )-import System.IO (IOMode (..), hClose, openFile)-import System.IO.Error (isDoesNotExistError)-import System.Process (showCommandForUser)--import Distribution.Compat.Environment-  ( lookupEnv-  , setEnv-  , unsetEnv-  )--import Distribution.Simple.Program-  ( Program (..)-  , ProgramDb-  , addKnownProgram-  , configureProgram-  , emptyProgramDb-  , getDbProgramOutput-  , runDbProgram-  , simpleProgram-  )-import Distribution.Simple.Setup (fromFlagOrDefault)-import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan, warn)--import Distribution.Client.Config (SavedConfig (..))-import Distribution.Client.GlobalFlags (GlobalFlags (..))--configureOneProgram :: Verbosity -> Program -> IO ProgramDb-configureOneProgram verb prog =-  configureProgram verb prog (addKnownProgram prog emptyProgramDb)--touchFile :: FilePath -> IO ()-touchFile path = do-  catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ()))-  createDirectoryIfMissing True (takeDirectory path)-  openFile path WriteMode >>= hClose--findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath)-findNixExpr globalFlags config = do-  -- criteria for deciding to run nix-shell-  let nixEnabled =-        fromFlagOrDefault-          False-          (globalNix (savedGlobalFlags config) <> globalNix globalFlags)--  if nixEnabled-    then do-      let exprPaths = ["shell.nix", "default.nix"]-      filterM doesFileExist exprPaths >>= \case-        [] -> return Nothing-        (path : _) -> return (Just path)-    else return Nothing---- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell-inFakeNixShell :: IO a -> IO a-inFakeNixShell f =-  bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f)-  where-    fakeEnv var new = do-      old <- lookupEnv var-      setEnv var new-      return old-    resetEnv var = maybe (unsetEnv var) (setEnv var)--nixInstantiate-  :: Verbosity-  -> FilePath-  -> Bool-  -> GlobalFlags-  -> SavedConfig-  -> IO ()-nixInstantiate verb dist force' globalFlags config =-  findNixExpr globalFlags config >>= \case-    Nothing -> return ()-    Just shellNix -> do-      alreadyInShell <- inNixShell-      shellDrv <- drvPath dist shellNix-      instantiated <- doesFileExist shellDrv-      -- an extra timestamp file is necessary because the derivation lives in-      -- the store so its mtime is always 1.-      let timestamp = timestampPath dist shellNix-      upToDate <- existsAndIsMoreRecentThan timestamp shellNix--      let ready = alreadyInShell || (instantiated && upToDate && not force')-      unless ready $ do-        let prog = simpleProgram "nix-instantiate"-        progdb <- configureOneProgram verb prog--        removeGCRoots verb dist-        touchFile timestamp--        _ <--          inFakeNixShell-            ( getDbProgramOutput-                verb-                prog-                progdb-                ["--add-root", shellDrv, "--indirect", shellNix]-            )-        return ()--nixShell-  :: Verbosity-  -> FilePath-  -> GlobalFlags-  -> SavedConfig-  -> IO ()-  -- ^ The action to perform inside a nix-shell. This is also the action-  -- that will be performed immediately if Nix is disabled.-  -> IO ()-nixShell verb dist globalFlags config go = do-  alreadyInShell <- inNixShell--  if alreadyInShell-    then go-    else do-      findNixExpr globalFlags config >>= \case-        Nothing -> go-        Just shellNix -> do-          -- Nix integration never worked with cabal-install v2 commands ...-          warn verb "Nix integration has been deprecated and will be removed in a future release. You can learn more about it here: https://cabal.readthedocs.io/en/latest/nix-integration.html"--          let prog = simpleProgram "nix-shell"-          progdb <- configureOneProgram verb prog--          cabal <- getExecutablePath--          -- alreadyInShell == True in child process-          setEnv "CABAL_IN_NIX_SHELL" "1"--          -- Run cabal with the same arguments inside nix-shell.-          -- When the child process reaches the top of nixShell, it will-          -- detect that it is running inside the shell and fall back-          -- automatically.-          shellDrv <- drvPath dist shellNix-          args <- getArgs-          runDbProgram-            verb-            prog-            progdb-            [ "--add-root"-            , gcrootPath dist </> "result"-            , "--indirect"-            , shellDrv-            , "--run"-            , showCommandForUser cabal args-            ]--drvPath :: FilePath -> FilePath -> IO FilePath-drvPath dist path = do-  -- We do not actually care about canonicity, but makeAbsolute is only-  -- available in newer versions of directory.-  -- We expect the path to be a symlink if it exists, so we do not canonicalize-  -- the entire path because that would dereference the symlink.-  distNix <- canonicalizePath (dist </> "nix")-  -- Nix garbage collector roots must be absolute paths-  return (distNix </> replaceExtension (takeFileName path) "drv")--timestampPath :: FilePath -> FilePath -> FilePath-timestampPath dist path =-  dist </> "nix" </> replaceExtension (takeFileName path) "drv.timestamp"--gcrootPath :: FilePath -> FilePath-gcrootPath dist = dist </> "nix" </> "gcroots"--inNixShell :: IO Bool-inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL"--removeGCRoots :: Verbosity -> FilePath -> IO ()-removeGCRoots verb dist = do-  let tgt = gcrootPath dist-  exists <- doesDirectoryExist tgt-  when exists $ do-    debug verb ("removing Nix gcroots from " ++ tgt)-    removeDirectoryRecursive tgt
src/Distribution/Client/NixStyleOptions.hs view
@@ -40,6 +40,7 @@   , liftOptions   , testOptions   )+import Distribution.Verbosity (VerbosityFlags, defaultVerbosityHandles, mkVerbosity)  data NixStyleFlags a = NixStyleFlags   { configFlags :: ConfigFlags@@ -157,5 +158,7 @@          in flags{benchmarkCommonFlags = setFlag common}     } -cfgVerbosity :: Verbosity -> NixStyleFlags a -> Verbosity-cfgVerbosity v flags = fromFlagOrDefault v (setupVerbosity . configCommonFlags $ configFlags flags)+cfgVerbosity :: VerbosityFlags -> NixStyleFlags a -> Verbosity+cfgVerbosity v flags =+  mkVerbosity defaultVerbosityHandles $+    fromFlagOrDefault v (setupVerbosity . configCommonFlags $ configFlags flags)
src/Distribution/Client/PackageHash.hs view
@@ -205,6 +205,7 @@   , pkgHashProfExe :: Bool   , pkgHashProfLibDetail :: ProfDetailLevel   , pkgHashProfExeDetail :: ProfDetailLevel+  , pkgHashBytecodeLib :: Bool   , pkgHashCoverage :: Bool   , pkgHashOptimization :: OptimisationLevel   , pkgHashSplitObjs :: Bool@@ -317,6 +318,7 @@           , opt "prof-exe" False prettyShow pkgHashProfExe           , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail           , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail+          , opt "bytecode-lib" False prettyShow pkgHashBytecodeLib           , opt "hpc" False prettyShow pkgHashCoverage           , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization           , opt "split-objs" False prettyShow pkgHashSplitObjs
src/Distribution/Client/ParseUtils.hs view
@@ -89,9 +89,9 @@ import qualified Distribution.FieldGrammar as FG import qualified Distribution.Fields as F import Distribution.Fields.ParseResult (runParseResult)-import Distribution.Parsec.Error (showPError)+import Distribution.Parsec.Error (showPErrorWithSource) import Distribution.Parsec.Position (Position (..))-import Distribution.Parsec.Warning (showPWarning)+import Distribution.Parsec.Warning (showPWarningWithSource) import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)  -------------------------@@ -230,14 +230,14 @@  -- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils -- that also optionally print default values for empty fields as comments.-ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+ppFields :: [FieldDescr a] -> Maybe a -> a -> Disp.Doc ppFields fields def cur =   Disp.vcat     [ ppField name (fmap getter def) (getter cur)     | FieldDescr name getter _ <- fields     ] -ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc+ppField :: String -> Maybe Disp.Doc -> Disp.Doc -> Disp.Doc ppField name mdef cur   | Disp.isEmpty cur =       maybe@@ -255,13 +255,13 @@ -- -- Since 'ppFields' does not cover subsections you can use this to add them. -- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.-ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+ppSection :: String -> String -> [FieldDescr a] -> Maybe a -> a -> Disp.Doc ppSection name arg fields def cur   | Disp.isEmpty fieldsDoc = Disp.empty   | otherwise =       Disp.text name         <+> argDoc-        $+$ (Disp.nest 2 fieldsDoc)+        $+$ Disp.nest 2 fieldsDoc   where     fieldsDoc = ppFields fields def cur     argDoc@@ -321,12 +321,12 @@                 ++ show line'           case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of             (warnings, Right b) -> do-              for_ warnings $ \w -> warning $ showPWarning "???" w+              for_ warnings $ \w -> warning $ showPWarningWithSource w               setter line param b a             (warnings, Left (_, errs)) -> do-              for_ warnings $ \w -> warning $ showPWarning "???" w+              for_ warnings $ \w -> warning $ showPWarningWithSource w               case errs of-                err :| _errs -> fail $ showPError "???" err+                err :| _errs -> fail $ showPErrorWithSource err         Nothing -> do           warning $             "Unrecognized section '"@@ -397,7 +397,7 @@   | otherwise =       Disp.text name         <+> argDoc-        $+$ (Disp.nest 2 fieldsDoc)+        $+$ Disp.nest 2 fieldsDoc   where     fieldsDoc = showConfig fields sections fgSections cur     argDoc@@ -421,7 +421,7 @@   | otherwise =       Disp.text secName         <+> argDoc-        $+$ (Disp.nest 2 fieldsDoc)+        $+$ Disp.nest 2 fieldsDoc   where     prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x
src/Distribution/Client/ProjectBuilding.hs view
@@ -87,10 +87,13 @@  import qualified Text.PrettyPrint as Disp +import Control.Concurrent.STM (TVar, newTVarIO) import Control.Exception (assert, handle)+import qualified Distribution.Client.IndexUtils as IndexUtils+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))-import System.Semaphore (SemaphoreName (..))+import System.Semaphore (SemaphoreIdentifier)  import Distribution.Client.Errors import Distribution.Simple.Flag (fromFlagOrDefault)@@ -367,6 +370,19 @@         createDirectoryIfMissingVerbose verbosity True distTempDirectory         traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse +        -- Populate the running InstalledPackageIndex by doing a single+        -- bulk read at startup. This allows us to obtain the+        -- InstalledPackageInfo of every 'PreExisting' and 'Installed' unit+        -- in the plan, regardless of how they ended up in the PackageDBs.+        -- See (ProjIPI1) in Note [Per-project InstalledPackageIndex].+        initialIPI <-+          -- NB: 'getInstalledPackages' returns an error when there are no+          -- PackageDBs, so we handle that case explicitly first.+          if null packageDBsToUse+            then return mempty+            else IndexUtils.getInstalledPackages verbosity compiler packageDBsToUse progdb+        ipiTVar <- newTVarIO initialIPI+         -- Concurrency control: create the job controller and concurrency limits         -- for downloading, building and installing.         withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do@@ -401,6 +417,7 @@                       cacheLock                       sharedPackageConfig                       installPlan+                      ipiTVar                       pkg                       pkgBuildStatus     where@@ -457,6 +474,34 @@           isRemote (RemoteSourceRepoPackage _ _) = True           isRemote _ = False +{- Note [Per-project InstalledPackageIndex]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In cabal-install, we keep a running InstalledPackageIndex, used for the whole+project, containing all registered units relevant to the project.++We do this to avoid repeatedly querying @ghc-pkg@ on a per-package basis when+configuring individual packages.++  (ProjIPI1)+    We initialise the index with a single @ghc-pkg dump@ invocation, which+    queries all the package DBs that the plan touches. This single read+    replaces the per-package query that 'computePackageInfo' would otherwise+    perform.++    This robustly handles the case of resuming an interrupted build.++  (ProjIPI2)+    During execution, each time we register a library, we insert its+    InstalledPackageInfo into the index, so that subsequent packages that+    depend on it have it available, without needing to re-query @ghc-pkg@.++  (ProjIPI3)+    Before configuring a package, we read the running InstalledPackageIndex+    and pass it to Cabal's 'computePackageInfoFromIndex' instead of+    'computePackageInfo', skipping the expensive per-package @ghc-pkg dump@+    invocation.+-}+ -- | Create a package DB if it does not currently exist. Note that this action -- is /not/ safe to run concurrently. createPackageDBIfMissing@@ -473,7 +518,7 @@     exists <- Cabal.doesPackageDBExist dbPath     unless exists $ do       createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)-      Cabal.createPackageDB verbosity compiler progdb False dbPath+      Cabal.createPackageDB verbosity compiler progdb dbPath createPackageDBIfMissing _ _ _ _ = return ()  -- | Given all the context and resources, (re)build an individual package.@@ -481,13 +526,14 @@   :: Verbosity   -> DistDirLayout   -> StoreDirLayout-  -> Maybe SemaphoreName+  -> Maybe SemaphoreIdentifier   -> BuildTimeSettings   -> AsyncFetchMap   -> Lock   -> Lock   -> ElaboratedSharedConfig   -> ElaboratedInstallPlan+  -> TVar InstalledPackageIndex   -> ElaboratedReadyPackage   -> BuildStatus   -> IO BuildResult@@ -502,6 +548,7 @@   cacheLock   sharedPackageConfig   plan+  ipiTVar   rpkg@(ReadyPackage pkg)   pkgBuildStatus     -- Technically, doing the --only-download filtering only in this function is@@ -588,6 +635,7 @@           sharedPackageConfig           plan           rpkg+          ipiTVar           srcdir           builddir @@ -604,6 +652,7 @@           sharedPackageConfig           plan           rpkg+          ipiTVar           buildStatus           srcdir           builddir@@ -713,7 +762,7 @@       BuildAndInstall ->         let tmpdir = distTempDirectory             builddir = relativeSymbolicPath $ makeRelativePathEx "dist"-         in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do+         in withTempDirectory tmpdir "src" $ \unpackdir -> do               let srcdir = makeSymbolicPath $ unpackdir </> prettyShow pkgid               unpackPackageTarball                 verbosity
src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs view
@@ -24,9 +24,9 @@ import Distribution.Simple.LocalBuildInfo   ( ComponentName (..)   )+import Distribution.Simple.Utils (removeFileForcibly)  import qualified Data.Set as Set-import Distribution.Client.Init.Types (removeExistingFile, runPromptIO)  ----------------------------- -- Package change detection@@ -151,9 +151,7 @@         pkgconfig     case configChanged of       MonitorChanged monitorReason ->-        return (Left (BuildStatusConfigure monitorReason'))-        where-          monitorReason' = fmap (const ()) monitorReason+        return (Left (BuildStatusConfigure $ void monitorReason))       MonitorUnchanged () _         -- The configChanged here includes the identity of the dependencies,         -- so depsBuildStatus is just needed for the changes in the content@@ -182,16 +180,14 @@               (MonitorChanged monitorReason, _) ->                 return (Left (BuildStatusBuild mreg buildReason))                 where-                  buildReason = BuildReasonFilesChanged monitorReason'-                  monitorReason' = fmap (const ()) monitorReason+                  buildReason = BuildReasonFilesChanged $ void monitorReason               (MonitorUnchanged _ _, MonitorChanged monitorReason) ->                 -- this should only happen if the file is corrupt or been                 -- manually deleted. We don't want to bother with another                 -- phase just for this, so we'll reregister by doing a build.                 return (Left (BuildStatusBuild Nothing buildReason))                 where-                  buildReason = BuildReasonFilesChanged monitorReason'-                  monitorReason' = fmap (const ()) monitorReason+                  buildReason = BuildReasonFilesChanged $ void monitorReason               (MonitorUnchanged _ _, MonitorUnchanged _ _)                 | pkgHasEphemeralBuildTargets pkg ->                     return (Left (BuildStatusBuild mreg buildReason))@@ -291,4 +287,4 @@  invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =-  runPromptIO $ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)+  removeFileForcibly (fileMonitorCacheFile pkgFileMonitorReg)
src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}  -- | This module exposes functions to build and register unpacked packages. --@@ -80,43 +83,49 @@   ( PackageDBStackCWD   , coercePackageDBStack   )+import qualified Distribution.Simple.Configure as Cabal import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo   ( ComponentName (..)   , LibraryName (..)   )+import qualified Distribution.Simple.LocalBuildInfo as Cabal+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.Setup as Cabal import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) +import Distribution.Client.Errors import Distribution.Simple.Utils import Distribution.System (Platform (..)) import Distribution.Utils.Path hiding   ( (<.>)   , (</>)   )+import Distribution.Verbosity (setVerbosityHandles) import Distribution.Version +import Distribution.Client.ProjectBuilding.PackageFileMonitor+ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 import qualified Data.List.NonEmpty as NE +import Control.Concurrent.STM (TVar, atomically, modifyTVar) import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile)+import Data.IORef (newIORef, readIORef, writeIORef)+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, listDirectory) import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>)) import System.IO (Handle, IOMode (AppendMode), withFile)-import System.Semaphore (SemaphoreName (..))+import System.Semaphore (SemaphoreIdentifier) +import GHC.Stack import Web.Browser (openBrowser) -import Distribution.Client.Errors-import Distribution.Compat.Directory (listDirectory)--import Distribution.Client.ProjectBuilding.PackageFileMonitor- -- | Each unpacked package is processed in the following phases: -- -- * Configure phase@@ -131,20 +140,24 @@ -- Depending on whether we are installing the package or building it inplace, -- the phases will be carried out differently. For example, when installing, -- the test, benchmark, and repl phase are ignored.-data PackageBuildingPhase-  = PBConfigurePhase {runConfigure :: IO ()}-  | PBBuildPhase {runBuild :: IO ()}-  | PBHaddockPhase {runHaddock :: IO ()}-  | PBInstallPhase-      { runCopy :: FilePath -> IO ()-      , runRegister+data PackageBuildingPhase r where+  PBConfigurePhase :: {runConfigure :: IO InLibraryLBI} -> PackageBuildingPhase InLibraryLBI+  PBBuildPhase :: {runBuild :: IO [MonitorFilePath]} -> PackageBuildingPhase ()+  PBHaddockPhase :: {runHaddock :: IO [MonitorFilePath]} -> PackageBuildingPhase ()+  PBReplPhase :: {runRepl :: IO [MonitorFilePath]} -> PackageBuildingPhase ()+  PBInstallPhase+    :: { runCopy :: FilePath -> IO ()+       , runRegister           :: PackageDBStackCWD           -> Cabal.RegisterOptions           -> IO InstalledPackageInfo-      }-  | PBTestPhase {runTest :: IO ()}-  | PBBenchPhase {runBench :: IO ()}-  | PBReplPhase {runRepl :: IO ()}+       , getInstalledPackageInfo :: IO InstalledPackageInfo+        -- ^ Compute the 'InstalledPackageInfo' from the build output,+        -- without registering with @ghc-pkg@. Deterministic.+       }+    -> PackageBuildingPhase ()+  PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase ()+  PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase ()  -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain@@ -153,7 +166,7 @@ buildAndRegisterUnpackedPackage   :: Verbosity   -> DistDirLayout-  -> Maybe SemaphoreName+  -> Maybe SemaphoreIdentifier   -- ^ Whether to pass a semaphore to build process   -- this is different to BuildTimeSettings because the   -- name of the semaphore is created freshly each time.@@ -163,17 +176,20 @@   -> ElaboratedSharedConfig   -> ElaboratedInstallPlan   -> ElaboratedReadyPackage+  -> TVar InstalledPackageIndex+  -- ^ Running 'InstalledPackageIndex', updated as @cabal-install@ registers+  -- packages   -> SymbolicPath CWD (Dir Pkg)   -> SymbolicPath Pkg (Dir Dist)   -> Maybe FilePath   -- ^ The path to an /initialized/ log file-  -> (PackageBuildingPhase -> IO ())+  -> (forall r. PackageBuildingPhase r -> IO r)   -> IO () buildAndRegisterUnpackedPackage   verbosity   distDirLayout@DistDirLayout{distTempDirectory}   maybe_semaphore-  buildTimeSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingKeepTempFiles}+  buildTimeSettings@BuildTimeSettings{buildSettingKeepTempFiles}   registerLock   cacheLock   pkgshared@ElaboratedSharedConfig@@ -182,42 +198,66 @@     }   plan   rpkg@(ReadyPackage pkg)+  ipiTVar   srcdir   builddir   mlogFile   delegate = do     -- Configure phase-    delegate $-      PBConfigurePhase $-        annotateFailure mlogFile ConfigureFailed $-          setup configureCommand Cabal.configCommonFlags configureFlags configureArgs+    mbLBI <-+      delegate $+        PBConfigurePhase $+          annotateFailure mlogFile ConfigureFailed $+            setup+              configureCommand+              Cabal.configCommonFlags+              configureFlags+              configureArgs+              (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg ipiTVar)      -- Build phase     delegate $       PBBuildPhase $         annotateFailure mlogFile BuildFailed $ do-          setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs+          setup+            buildCommand+            Cabal.buildCommonFlags+            (return . buildFlags)+            buildArgs+            (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI)      -- Haddock phase     whenHaddock $       delegate $         PBHaddockPhase $           annotateFailure mlogFile HaddocksFailed $ do-            setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs+            setup+              haddockCommand+              Cabal.haddockCommonFlags+              (return . haddockFlags)+              haddockArgs+              (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI)      -- Install phase+    let getIpkg = do+          -- Grab and modify the InstalledPackageInfo. We decide what+          -- the installed package id is, not the build system.+          ipkg0 <- generateInstalledPackageInfo mbLBI+          return ipkg0{Installed.installedUnitId = uid}     delegate $       PBInstallPhase         { runCopy = \destdir ->             annotateFailure mlogFile InstallFailed $-              setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs+              setup+                Cabal.copyCommand+                Cabal.copyCommonFlags+                (return . copyFlags destdir)+                copyArgs+                (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI)         , runRegister = \pkgDBStack registerOpts ->             annotateFailure mlogFile InstallFailed $ do-              -- We register ourselves rather than via Setup.hs. We need to-              -- grab and modify the InstalledPackageInfo. We decide what-              -- the installed package id is, not the build system.-              ipkg0 <- generateInstalledPackageInfo-              let ipkg = ipkg0{Installed.installedUnitId = uid}+              -- We register ourselves, rather than via Setup.hs.+              ipkg <- getIpkg               criticalSection registerLock $                 Cabal.registerPackage                   verbosity@@ -228,6 +268,7 @@                   ipkg                   registerOpts               return ipkg+        , getInstalledPackageInfo = getIpkg         }      -- Test phase@@ -235,28 +276,43 @@       delegate $         PBTestPhase $           annotateFailure mlogFile TestsFailed $-            setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs+            setup+              testCommand+              Cabal.testCommonFlags+              (return . testFlags)+              testArgs+              (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI)      -- Bench phase     whenBench $       delegate $         PBBenchPhase $           annotateFailure mlogFile BenchFailed $-            setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs+            setup+              benchCommand+              Cabal.benchmarkCommonFlags+              (return . benchFlags)+              benchArgs+              (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI)      -- Repl phase     whenRepl $       delegate $         PBReplPhase $           annotateFailure mlogFile ReplFailed $-            setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs+            setupInteractive+              replCommand+              Cabal.replCommonFlags+              (return . replFlags)+              replArgs+              (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI)      return ()     where       uid = installedUnitId rpkg        comp_par_strat = case maybe_semaphore of-        Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name)+        Just sem_ident -> Cabal.toFlag sem_ident         _ -> Cabal.NoFlag        whenTest action@@ -276,17 +332,18 @@         | otherwise = return ()        mbWorkDir = useWorkingDir scriptOptions-      commonFlags = setupHsCommonFlags verbosity mbWorkDir builddir buildSettingKeepTempFiles+      commonFlags targets =+        setupHsCommonFlags verbosity mbWorkDir builddir targets buildSettingKeepTempFiles        configureCommand = Cabal.configureCommand defaultProgramDb       configureFlags v =         flip filterConfigureFlags v           <$> setupHsConfigureFlags-            (\p -> makeSymbolicPath <$> canonicalizePath p)+            (fmap makeSymbolicPath . canonicalizePath)             plan             rpkg             pkgshared-            commonFlags+            (commonFlags $ configureArgs v)       configureArgs _ = setupHsConfigureArgs pkg        buildCommand = Cabal.buildCommand defaultProgramDb@@ -296,7 +353,7 @@             comp_par_strat             pkg             pkgshared-            commonFlags+            (commonFlags $ buildArgs v)       buildArgs _ = setupHsBuildArgs pkg        copyFlags destdir v =@@ -304,7 +361,7 @@           setupHsCopyFlags             pkg             pkgshared-            commonFlags+            (commonFlags $ buildArgs v)             destdir       -- In theory, we could want to copy less things than those that were       -- built, but instead, we simply copy the targets that were built.@@ -315,7 +372,7 @@         flip filterTestFlags v $           setupHsTestFlags             pkg-            commonFlags+            (commonFlags $ testArgs v)       testArgs _ = setupHsTestArgs pkg        benchCommand = Cabal.benchmarkCommand@@ -324,7 +381,7 @@           setupHsBenchFlags             pkg             pkgshared-            commonFlags+            (commonFlags $ benchArgs v)       benchArgs _ = setupHsBenchArgs pkg        replCommand = Cabal.replCommand defaultProgramDb@@ -333,7 +390,7 @@           setupHsReplFlags             pkg             pkgshared-            commonFlags+            (commonFlags $ replArgs v)       replArgs _ = setupHsReplArgs pkg        haddockCommand = Cabal.haddockCommand@@ -343,7 +400,7 @@             pkg             pkgshared             buildTimeSettings-            commonFlags+            (commonFlags $ haddockArgs v)       haddockArgs v =         flip filterHaddockArgs v $           setupHsHaddockArgs pkg@@ -356,19 +413,20 @@           distDirLayout           srcdir           builddir-          (isParallelBuild buildSettingNumJobs)           cacheLock        setup-        :: CommandUI flags+        :: (HasCallStack, RightFlagsForPhase flags setupSpec)+        => CommandUI flags         -> (flags -> CommonSetupFlags)         -> (Version -> IO flags)         -> (Version -> [String])-        -> IO ()-      setup cmd getCommonFlags flags args =-        withLogging $ \mLogFileHandle -> do+        -> SetupRunnerArgs setupSpec+        -> IO (SetupRunnerRes setupSpec)+      setup cmd getCommonFlags flags args wrapperArgs =+        withLogging $ \mLogFileHandle ->           setupWrapper-            verbosity+            (setVerbosityHandles mLogFileHandle verbosity)             scriptOptions               { useLoggingHandle = mLogFileHandle               , useExtraEnvOverrides =@@ -381,25 +439,24 @@             getCommonFlags             flags             args+            wrapperArgs        setupInteractive-        :: CommandUI flags+        :: RightFlagsForPhase flags setupSpec+        => CommandUI flags         -> (flags -> CommonSetupFlags)-        -> (Version -> flags)+        -> (Version -> IO flags)         -> (Version -> [String])-        -> IO ()-      setupInteractive cmd getCommonFlags flags args =+        -> SetupRunnerArgs setupSpec+        -> IO (SetupRunnerRes setupSpec)+      setupInteractive =         setupWrapper           verbosity           scriptOptions{isInteractive = True}           (Just (elabPkgDescription pkg))-          cmd-          getCommonFlags-          (\v -> return (flags v))-          args -      generateInstalledPackageInfo :: IO InstalledPackageInfo-      generateInstalledPackageInfo =+      generateInstalledPackageInfo :: InLibraryLBI -> IO InstalledPackageInfo+      generateInstalledPackageInfo mbLBI =         withTempInstalledPackageInfoFile           verbosity           distTempDirectory@@ -409,9 +466,14 @@                     setupHsRegisterFlags                       pkg                       pkgshared-                      commonFlags+                      (commonFlags [])                       pkgConfDest-            setup (Cabal.registerCommand) Cabal.registerCommonFlags (\v -> return (registerFlags v)) (const [])+            setup+              Cabal.registerCommand+              Cabal.registerCommonFlags+              (return . registerFlags)+              (const [])+              (InLibraryArgs $ InLibraryPostConfigureArgs SRegisterPhase mbLBI)        withLogging :: (Maybe Handle -> IO r) -> IO r       withLogging action =@@ -428,13 +490,14 @@ buildInplaceUnpackedPackage   :: Verbosity   -> DistDirLayout-  -> Maybe SemaphoreName+  -> Maybe SemaphoreIdentifier   -> BuildTimeSettings   -> Lock   -> Lock   -> ElaboratedSharedConfig   -> ElaboratedInstallPlan   -> ElaboratedReadyPackage+  -> TVar InstalledPackageIndex   -> BuildStatusRebuild   -> SymbolicPath CWD (Dir Pkg)   -> SymbolicPath Pkg (Dir Dist)@@ -453,6 +516,7 @@   pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os}   plan   rpkg@(ReadyPackage pkg)+  ipiTVar   buildStatus   srcdir   builddir = do@@ -465,12 +529,6 @@       True       (distPackageCacheDirectory dparams) -    let docsResult = DocsNotTried-        testsResult = TestsNotTried--        buildResult :: BuildResultMisc-        buildResult = (docsResult, testsResult)-     buildAndRegisterUnpackedPackage       verbosity       distDirLayout@@ -481,69 +539,23 @@       pkgshared       plan       rpkg+      ipiTVar       srcdir       builddir       Nothing -- no log file for inplace builds!       $ \case-        PBConfigurePhase{runConfigure} -> do-          whenReConfigure $ do-            runConfigure+        PBConfigurePhase{runConfigure} ->+          whenReconfigure $ do+            mbLBI <- runConfigure             invalidatePackageRegFileMonitor packageFileMonitor             updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg-        PBBuildPhase{runBuild} -> do-          whenRebuild $ do-            timestamp <- beginUpdateFileMonitor-            runBuild-              -- Be sure to invalidate the cache if building throws an exception!-              -- If not, we'll abort execution with a stale recompilation cache.-              -- See ghc#24926 for an example of how this can go wrong.-              `onException` invalidatePackageRegFileMonitor packageFileMonitor--            let listSimple =-                  execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg)-                listSdist =-                  fmap (map monitorFileHashed) $-                    allPackageSourceFiles verbosity (getSymbolicPath srcdir)-                ifNullThen m m' = do-                  xs <- m-                  if null xs then m' else return xs-            monitors <- case PD.buildType (elabPkgDescription pkg) of-              Simple -> listSimple-              -- If a Custom setup was used, AND the Cabal is recent-              -- enough to have sdist --list-sources, use that to-              -- determine the files that we need to track.  This can-              -- cause unnecessary rebuilding (for example, if README-              -- is edited, we will try to rebuild) but there isn't-              -- a more accurate Custom interface we can use to get-              -- this info.  We prefer not to use listSimple here-              -- as it can miss extra source files that are considered-              -- by the Custom setup.-              _-                | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->-                    -- However, sometimes sdist --list-sources will fail-                    -- and return an empty list.  In that case, fall-                    -- back on the (inaccurate) simple tracking.-                    listSdist `ifNullThen` listSimple-                | otherwise ->-                    listSimple--            let dep_monitors =-                  map monitorFileHashed $-                    elabInplaceDependencyBuildCacheFiles-                      distDirLayout-                      pkgshared-                      plan-                      pkg-            updatePackageBuildFileMonitor-              packageFileMonitor-              (getSymbolicPath srcdir)-              timestamp-              pkg-              buildStatus-              (monitors ++ dep_monitors)-              buildResult+            return mbLBI+        PBBuildPhase{runBuild} ->+          whenRebuild $ withFileMonitor runBuild+        PBReplPhase{runRepl} ->+          withFileMonitor runRepl         PBHaddockPhase{runHaddock} -> do-          runHaddock+          withFileMonitor runHaddock           let haddockTarget = elabHaddockForHackage pkg           when (haddockTarget == Cabal.ForHackage) $ do             let dest = distDirectory </> name <.> "tar.gz"@@ -580,13 +592,16 @@                     runRegister                       (elabRegisterPackageDBStack pkg)                       Cabal.defaultRegisterOptions+                  -- Keep the per-project running InstalledPackageIndex up to date.+                  -- See (ProjIPI2) from Note [Per-project InstalledPackageIndex]+                  -- in Distribution.Client.ProjectBuilding.+                  atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg)                   return (Just ipkg)                 else return Nothing              updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg         PBTestPhase{runTest} -> runTest         PBBenchPhase{runBench} -> runBench-        PBReplPhase{runRepl} -> runRepl      return       BuildResult@@ -595,14 +610,85 @@         , buildResultLogFile = Nothing         }     where+      docsResult = DocsNotTried+      testsResult = TestsNotTried+      buildResult :: BuildResultMisc+      buildResult = (docsResult, testsResult)+       dparams = elabDistDirParams pkgshared pkg        packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams -      whenReConfigure action = case buildStatus of-        BuildStatusConfigure _ -> action-        _ -> return ()+      withFileMonitor :: IO [MonitorFilePath] -> IO ()+      withFileMonitor runAction = do+        timestamp <- beginUpdateFileMonitor+        monitors' <-+          runAction+            -- Be sure to invalidate the cache if building throws an exception!+            -- If not, we'll abort execution with a stale recompilation cache.+            -- See ghc#24926 for an example of how this can go wrong.+            `onException` invalidatePackageRegFileMonitor packageFileMonitor+        let listSimple =+              execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg)+            listSdist =+              fmap (map monitorFileHashed) $+                allPackageSourceFiles verbosity (getSymbolicPath srcdir)+            ifNullThen m m' = do+              xs <- m+              if null xs then m' else return xs+        monitors <- case PD.buildType (elabPkgDescription pkg) of+          Simple -> listSimple+          Hooks -> listSdist `ifNullThen` listSimple+          _+            | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->+                listSdist `ifNullThen` listSimple+            | otherwise ->+                listSimple +        let dep_monitors =+              map monitorFileHashed $+                elabInplaceDependencyBuildCacheFiles+                  distDirLayout+                  pkgshared+                  plan+                  pkg+        updatePackageBuildFileMonitor+          packageFileMonitor+          (getSymbolicPath srcdir)+          timestamp+          pkg+          buildStatus+          (monitors ++ monitors' ++ dep_monitors)+          buildResult++      whenReconfigure :: IO InLibraryLBI -> IO InLibraryLBI+      whenReconfigure action =+        case buildStatus of+          BuildStatusConfigure _ -> action+          _ -> do+            -- We are skipping reconfiguration, so we recover the+            -- 'LocalBuildInfo' persisted by the previous 'configure'.+            mbOldLBI <- Cabal.tryGetPersistBuildConfig (Just srcdir) builddir+            case mbOldLBI of+              -- #11942: if the previous LocalBuildInfo was written by an+              -- external Setup.hs with an incompatible Cabal library version,+              -- then we must continue to use the external setup method.+              Left Cabal.ConfigStateFileBadVersion{} -> return NotInLibraryNoLBI+              -- Other errors reflect genuine problems: re-throw them.+              Left err -> throwIO err+              Right lbi_wo_programs -> do+                -- Restore info about unconfigured programs, since it is not serialized+                -- TODO: copied from Distribution.Simple.getBuildConfig.+                let lbi =+                      lbi_wo_programs+                        { Cabal.withPrograms =+                            restoreProgramDb+                              builtinPrograms+                              (Cabal.withPrograms lbi_wo_programs)+                        }+                return $ InLibraryLBI lbi++      whenRebuild, whenReRegister :: IO () -> IO ()       whenRebuild action         | null (elabBuildTargets pkg)         , -- NB: we have to build the test/bench suite!@@ -613,7 +699,10 @@        whenReRegister action =         case buildStatus of-          -- We registered the package already+          -- We registered the package already.+          -- No need to update ipiTVar: the InstalledPackageInfo for this package+          -- was picked up at startup.+          -- See Note [Per-project InstalledPackageIndex] in Distribution.Client.ProjectBuilding.           BuildStatusBuild (Just _) _ ->             info verbosity "whenReRegister: previously registered"           -- There is nothing to register@@ -632,7 +721,7 @@   :: Verbosity   -> DistDirLayout   -> StoreDirLayout-  -> Maybe SemaphoreName+  -> Maybe SemaphoreIdentifier   -- ^ Whether to pass a semaphore to build process   -- this is different to BuildTimeSettings because the   -- name of the semaphore is created freshly each time.@@ -642,6 +731,7 @@   -> ElaboratedSharedConfig   -> ElaboratedInstallPlan   -> ElaboratedReadyPackage+  -> TVar InstalledPackageIndex   -> SymbolicPath CWD (Dir Pkg)   -> SymbolicPath Pkg (Dir Dist)   -> IO BuildResult@@ -661,6 +751,7 @@     }   plan   rpkg@(ReadyPackage pkg)+  ipiTVar   srcdir   builddir = do     createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPath (Just srcdir) builddir)@@ -688,6 +779,7 @@       pkgshared       plan       rpkg+      ipiTVar       srcdir       builddir       mlogFile@@ -697,13 +789,19 @@           runConfigure         PBBuildPhase{runBuild} -> do           noticeProgress ProgressBuilding-          runBuild+          _monitors <- runBuild+          return ()         PBHaddockPhase{runHaddock} -> do           noticeProgress ProgressHaddock-          runHaddock-        PBInstallPhase{runCopy, runRegister} -> do+          _monitors <- runHaddock+          return ()+        PBInstallPhase{runCopy, runRegister, getInstalledPackageInfo} -> do           noticeProgress ProgressInstalling +          -- Create an IORef used to retrieve the InstalledPackageInfo computed+          -- by running "register".+          ipkgRef <- newIORef Nothing+           let registerPkg                 | not (elabRequiresRegistration pkg) =                     debug verbosity $@@ -715,14 +813,15 @@                           == storePackageDBStack compiler (elabPackageDbs pkg)                       )                       (return ())-                    _ <-+                    ipkg <-                       runRegister                         (elabRegisterPackageDBStack pkg)                         Cabal.defaultRegisterOptions                           { Cabal.registerMultiInstance = True                           , Cabal.registerSuppressFilesCheck = True                           }-                    return ()+                    -- Write the InstalledPackageInfo to the IORef+                    writeIORef ipkgRef (Just ipkg)            -- Actual installation           void $@@ -734,6 +833,20 @@               (copyPkgFiles verbosity pkgshared pkg runCopy)               registerPkg +          -- Keep the per-project running InstalledPackageIndex TVar up to date.+          -- This must run regardless of whether newStoreEntry won or lost the+          -- race (UseNewStoreEntry/UseExistingStoreEntry).+          --+          -- See (ProjIPI2) in Note [Per-project InstalledPackageIndex].+          when (elabRequiresRegistration pkg) $ do+            -- If we won the race, we use the InstalledPackageInfo that was+            -- computed by 'runRegister'. If we lost, then we fall back to+            -- 'getInstalledPackageInfo' which re-runs 'Cabal register'+            -- (takes ~100ms).+            mipkg <- readIORef ipkgRef+            ipkg <- maybe getInstalledPackageInfo return mipkg+            atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg)+         -- No tests on install         PBTestPhase{} -> return ()         -- No bench on install@@ -799,8 +912,7 @@           Nothing -> return ()           Just logFile -> do             createDirectoryIfMissing True (takeDirectory logFile)-            exists <- doesFileExist logFile-            when exists $ removeFile logFile+            removeFileForcibly logFile  -- | The copy part of the installation phase when doing build-and-install copyPkgFiles@@ -862,7 +974,7 @@   where     listFilesRecursive :: FilePath -> IO [FilePath]     listFilesRecursive path = do-      files <- fmap (path </>) <$> (listDirectory path)+      files <- fmap (path </>) <$> listDirectory path       allFiles <- for files $ \file -> do         isDir <- doesDirectoryExist file         if isDir@@ -891,11 +1003,7 @@     -- lots, including exceptions from the hackage-security and tar packages.     -- So we take the strategy of catching everything except async exceptions.     [-#if MIN_VERSION_base(4,7,0)       Handler $ \async -> throwIO (async :: SomeAsyncException)-#else-      Handler $ \async -> throwIO (async :: AsyncException)-#endif     , Handler $ \other -> handler (other :: SomeException)     ]   where@@ -937,7 +1045,7 @@   -> (FilePath -> IO ())   -> IO InstalledPackageInfo withTempInstalledPackageInfoFile verbosity tempdir action =-  withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do+  withTempDirectory tempdir "package-registration-" $ \dir -> do     -- make absolute since @action@ will often change directory     abs_dir <- canonicalizePath dir
src/Distribution/Client/ProjectConfig.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}  -- | Handling project configuration. module Distribution.Client.ProjectConfig@@ -11,6 +13,7 @@   , ProjectConfigToParse (..)   , ProjectConfigBuildOnly (..)   , ProjectConfigShared (..)+  , ProjectConfigSkeleton   , ProjectConfigProvenance (..)   , PackageConfig (..)   , MapLast (..)@@ -40,6 +43,12 @@   , readSourcePackageCabalFile   , readSourcePackageCabalFile'   , CabalFileParseError (..)+  , readProjectFileSkeleton+  , ProjectFileParser (..)+  , readProjectFileSkeletonLegacy+  , readProjectFileSkeletonParsec+  , readProjectFileSkeletonFallback+  , readProjectFileSkeletonCompare      -- * Packages within projects   , ProjectPackageLocation (..)@@ -67,10 +76,14 @@   , maxNumFetchJobs   ) where +import Data.Bifunctor (second) import Distribution.Client.Compat.Prelude hiding (empty)+import Distribution.Parsec.Source import Distribution.Simple.Utils   ( createDirectoryIfMissingVerbose+  , debug   , dieWithException+  , info   , maybeExit   , notice   , noticeDoc@@ -86,6 +99,7 @@   ) import Distribution.Client.JobControl import Distribution.Client.ProjectConfig.Legacy+import qualified Distribution.Client.ProjectConfig.Parsec as Parsec import Distribution.Client.ProjectConfig.Types import Distribution.Client.RebuildMonad import Distribution.Client.VCS@@ -96,6 +110,7 @@   , syncSourceRepos   , validateSourceRepos   )+import Distribution.Fields.ParseResult  import Distribution.Client.BuildReports.Types   ( ReportLevel (..)@@ -107,9 +122,11 @@ import Distribution.Client.DistDirLayout   ( CabalDirLayout (..)   , DistDirLayout (..)+  , ProjectFileKey (..)   , ProjectRoot (..)   , defaultProjectFile   )+import Distribution.Client.Errors.Parser import Distribution.Client.GlobalFlags   ( RepoContext (..)   , withRepoContext'@@ -122,7 +139,6 @@   , transportCheckHttps   ) import Distribution.Client.Types-import Distribution.Client.Utils.Parsec (renderParseError)  import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint@@ -154,11 +170,6 @@   ( ProjectParseResult (..)   ) import Distribution.Fields-  ( PError-  , PWarning-  , runParseResult-  , showPWarning-  ) import Distribution.Package import Distribution.PackageDescription.Parsec   ( parseGenericPackageDescription@@ -206,9 +217,6 @@   ( fromNubList   ) import Distribution.Verbosity-  ( modifyVerbosity-  , verbose-  ) import Distribution.Version  import qualified Codec.Archive.Tar as Tar@@ -236,8 +244,8 @@   , doesFileExist   , doesPathExist   , getCurrentDirectory-  , getDirectoryContents   , getHomeDirectory+  , listDirectory   , pathIsSymbolicLink   ) import System.FilePath hiding (combine)@@ -246,6 +254,7 @@   , withBinaryFile   ) +import Distribution.Client.ProjectConfig.Import import Distribution.Deprecated.ProjectParseUtils (ProjectParseError (..), ProjectParseWarning) import Distribution.Solver.Types.ProjectConfigPath @@ -257,7 +266,7 @@ -- 'PackageName'. This returns the configuration that applies to all local -- packages plus any package-specific configuration for this package. lookupLocalPackageConfig-  :: (Semigroup a, Monoid a)+  :: Monoid a   => (PackageConfig -> a)   -> ProjectConfig   -> PackageName@@ -532,7 +541,7 @@       --       buildSettingLogVerbosity :: Verbosity       buildSettingLogVerbosity-        | overrideVerbosity = modifyVerbosity (max verbose) verbosity+        | overrideVerbosity = modifyVerbosityFlags makeVerbose verbosity         | otherwise = verbosity        overrideVerbosity :: Bool@@ -552,7 +561,7 @@ resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs =   if fromFlag projectConfigUseSemaphore     then UseSem (determineNumJobs projectConfigNumJobs)-    else case (determineNumJobs projectConfigNumJobs) of+    else case determineNumJobs projectConfigNumJobs of       1 -> Serial       n -> NumJobs (Just n) @@ -603,8 +612,7 @@            getProjectRootUsability file >>= \case             ProjectRootUsabilityPresentAndUsable ->-              uncurry projectRoot-                =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file+              uncurry projectRoot . first dropTrailingPathSeparator . splitFileName =<< canonicalizePath file             ProjectRootUsabilityNotPresent ->               left (BadProjectRootExplicitFileNotFound file)             ProjectRootUsabilityPresentAndUnusable ->@@ -751,35 +759,37 @@ -- file if any, plus other global config. readProjectConfig   :: Verbosity+  -> ProjectFileParser   -> HttpTransport   -> Flag Bool   -- ^ @--ignore-project@   -> Flag FilePath   -> DistDirLayout   -> Rebuild ProjectConfigSkeleton-readProjectConfig verbosity _ (Flag True) configFileFlag _ = do+readProjectConfig verbosity parserOption _ (Flag True) configFileFlag _ = do   global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag   return (global <> singletonProjectConfigSkeleton defaultImplicitProjectConfig)-readProjectConfig verbosity httpTransport _ configFileFlag distDirLayout = do+readProjectConfig verbosity parserOption httpTransport _ configFileFlag distDirLayout = do   global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag-  local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout-  freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout-  extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout+  local <- readProjectLocalConfigOrDefault verbosity parserOption httpTransport distDirLayout+  freeze <- readProjectLocalFreezeConfig verbosity parserOption httpTransport distDirLayout+  extra <- readProjectLocalExtraConfig verbosity parserOption httpTransport distDirLayout   return (global <> local <> freeze <> extra)  -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. readProjectLocalConfigOrDefault   :: Verbosity+  -> ProjectFileParser   -> HttpTransport   -> DistDirLayout   -> Rebuild ProjectConfigSkeleton-readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do-  let projectFile = distProjectFile distDirLayout ""+readProjectLocalConfigOrDefault verbosity parserOption httpTransport distDirLayout = do+  let projectFile = distProjectFile distDirLayout ProjectFileKeyMain   usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile   if usesExplicitProjectRoot     then do-      readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file"+      readProjectFileSkeleton parserOption verbosity httpTransport distDirLayout ProjectFileKeyMain     else do       monitorFiles [monitorNonExistentFile projectFile]       return (singletonProjectConfigSkeleton defaultImplicitProjectConfig)@@ -792,64 +802,212 @@     , projectConfigProvenance = Set.singleton Implicit     } +-- | A human readable description of the project file.+extensionDescription :: ProjectFileKey -> String+extensionDescription = \case+  ProjectFileKeyMain -> "project file"+  ProjectFileKeyLocal -> "project local configuration file"+  ProjectFileKeyFreeze -> "project freeze file"+ -- | Reads a @cabal.project.local@ file in the given project root dir, -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. readProjectLocalExtraConfig   :: Verbosity+  -> ProjectFileParser   -> HttpTransport   -> DistDirLayout   -> Rebuild ProjectConfigSkeleton-readProjectLocalExtraConfig verbosity httpTransport distDirLayout =+readProjectLocalExtraConfig verbosity parserOption httpTransport distDirLayout =   readProjectFileSkeleton+    parserOption     verbosity     httpTransport     distDirLayout-    "local"-    "project local configuration file"+    ProjectFileKeyLocal  -- | Reads a @cabal.project.freeze@ file in the given project root dir, -- or returns empty. This file gets written by @cabal freeze@, or in -- principle can be edited manually or by other tools. readProjectLocalFreezeConfig   :: Verbosity+  -> ProjectFileParser   -> HttpTransport   -> DistDirLayout   -> Rebuild ProjectConfigSkeleton-readProjectLocalFreezeConfig verbosity httpTransport distDirLayout =+readProjectLocalFreezeConfig verbosity parserOption httpTransport distDirLayout =   readProjectFileSkeleton+    parserOption     verbosity     httpTransport     distDirLayout-    "freeze"-    "project freeze file"+    ProjectFileKeyFreeze  -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.-readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton-readProjectFileSkeleton+-- This function is generic and can be used with the legacy or parsec parser, or a combination of both.+readProjectFileSkeletonGen :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> (FilePath -> IO ProjectConfigSkeleton) -> Rebuild ProjectConfigSkeleton+readProjectFileSkeletonGen   verbosity   httpTransport-  DistDirLayout{distProjectFile, distDownloadSrcDirectory}-  extensionName-  extensionDescription = do-    exists <- liftIO $ doesFileExist extensionFile-    if exists-      then do-        monitorFiles [monitorFileHashed extensionFile]-        pcs <- liftIO readExtensionFile-        monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs)-        pure pcs-      else do-        monitorFiles [monitorNonExistentFile extensionFile]-        return mempty+  DistDirLayout{distProjectFile, distProjectRootDirectory}+  key+  parseConfig =+    do+      exists <- liftIO $ doesFileExist extensionFile+      if exists+        then do+          monitorLog $ "Monitor existing: " ++ fileWithAbsolute extensionFile+          monitorFiles [monitorFileHashed extensionFile]+          pcs <- liftIO $ parseConfig extensionFile+          let paths =+                [ currentProjectConfigPath path+                | (Nothing, path) <- projectSkeletonImports pcs+                ]+          for_ paths $ \p -> do+            monitorLog $ "Monitor imported: " ++ fileWithAbsolute p+          monitorFiles $ monitorFileHashed <$> paths+          return pcs+        else do+          monitorLog $ "Monitor nonexistent: " ++ fileWithAbsolute extensionFile+          monitorFiles [monitorNonExistentFile extensionFile]+          return mempty     where-      extensionFile = distProjectFile extensionName+      monitorLog = liftIO . info verbosity+      extensionFile = distProjectFile key -      readExtensionFile =-        reportParseResult verbosity extensionDescription extensionFile-          =<< parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity . ProjectConfigToParse-          =<< BS.readFile extensionFile+      fileWithAbsolute f+        | isAbsolute f = f+        | otherwise = f ++ " (" ++ makeAbsolute f ++ ")" +      makeAbsolute f+        | isAbsolute f = f+        | otherwise = distProjectRootDirectory </> f++-- There are 3 different variants of the project parsing function.+-- 1. readProjectFileSkeletonLegacy: always uses the legacy parser+-- 2. readProjectFileSkeletonParsec: always uses the parsec parser+-- 3. readProjectFileSkeletonFallback: uses the parsec parser, but if that fails, it falls back to the legacy parser.+-- 4. readProjectFileSkeletonCompare: Run both parsers, and compare the results to check they are the same.+--+--+-- correspondingly there are two "pure" functions to attempt to parse a project+-- file using the "legacy" or "parsec" parser.+--+-- 1. parseProjectFileSkeletonLegacy: parses a project file using the legacy parser+-- 2. parseProjectFileSkeletonParsec: parses a project file using the parsec parser+--+-- Errors are handled in each case by+--+-- 1. reportParseResult: reports legacy parse errors to the user+-- 2. reportParseResultParsec: reports parsec parse errors to the user++readProjectFileSkeleton :: ProjectFileParser -> Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> Rebuild ProjectConfigSkeleton+readProjectFileSkeleton option =+  case option of+    LegacyParser -> readProjectFileSkeletonLegacy+    ParsecParser -> readProjectFileSkeletonParsec+    FallbackParser -> readProjectFileSkeletonFallback+    CompareParser -> readProjectFileSkeletonCompare++-- | Read a project file using the legacy parser.+readProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> Rebuild ProjectConfigSkeleton+readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout key = do+  readProjectFileSkeletonGen verbosity httpTransport distDirLayout key $ \fp -> do+    debug verbosity "Reading project file using the legacy parser"+    parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout key fp+      >>= liftIO . reportParseResult verbosity (extensionDescription key) fp++-- | Read a project file using the parsec parser, but if that fails, it falls back to the legacy parser.+readProjectFileSkeletonFallback :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> Rebuild ProjectConfigSkeleton+readProjectFileSkeletonFallback verbosity httpTransport distDirLayout key = do+  readProjectFileSkeletonGen verbosity httpTransport distDirLayout key $ \fp -> do+    debug verbosity "Reading project file using the fallback parser"+    (res, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout key fp+    let (_, pres) = runParseResult res+    case pres of+      -- 1. Successful parse with parsec parser, handle the result as normal.+      Right{} -> liftIO $ reportParseResultParsec verbosity fp bs res+      -- 2. The parse failed with the parsec parser, fallback to the legacy parser.+      Left{} -> do+        lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout key fp+        case lres of+          -- 3a. The legacy parser worked, but the parsec parser failed!+          -- Report a warning to the user that this happened.+          OldParser.ProjectParseOk{} -> do+            warn verbosity "The new parsec parser failed, but the legacy parser worked. This is unexpected, please report this as a bug.\nThe legacy parser will be removed in the next major version."+            liftIO $ reportParseResult verbosity (extensionDescription key) fp lres+          -- 3b. The legacy parser failed as well, report the original error.+          OldParser.ProjectParseFailed{} -> do+            liftIO $ reportParseResultParsec verbosity fp bs res++-- | Read a project file using the parsec parser.+readProjectFileSkeletonParsec :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> Rebuild ProjectConfigSkeleton+readProjectFileSkeletonParsec verbosity httpTransport distDirLayout key = do+  readProjectFileSkeletonGen verbosity httpTransport distDirLayout key $ \fp -> do+    debug verbosity "Reading project file using the parsec parser"+    (res, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout key fp+    liftIO $ reportParseResultParsec verbosity fp bs res++readProjectFileSkeletonCompare :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> Rebuild ProjectConfigSkeleton+readProjectFileSkeletonCompare verbosity httpTransport distDirLayout key = do+  readProjectFileSkeletonGen verbosity httpTransport distDirLayout key $ \fp -> do+    debug verbosity "Reading project file using the comparative parser"+    (pres, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout key fp+    lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout key fp+    let (_, ppres) = runParseResult pres+    case (lres, ppres) of+      -- 1. Both succeed, compare the results+      (OldParser.ProjectParseOk lwarns lpcs, Right ppcs) -> do+        unless (lpcs == ppcs) (dieWithException verbosity $ LegacyAndParsecParseResultsDiffer fp (show lpcs) (show ppcs))+        liftIO $ reportParseResultParsec verbosity fp bs pres+      -- 2. The legacy parser failed, but the parsec parser succeeded.+      -- Report a warning to the user that this happened.+      (OldParser.ProjectParseFailed{}, Right{}) -> do+        warn verbosity "The legacy parser failed, but the new parsec parser worked. This is unexpected, please report this as a bug.\nThe legacy parser will be removed in the next major version."+        liftIO $ reportParseResult verbosity (extensionDescription key) fp lres+      -- 3. The legacy parser succeeded, but the parsec parser failed.+      -- Report a warning to the user that this happened.+      (OldParser.ProjectParseOk{}, Left{}) -> do+        warn verbosity "The new parsec parser failed, but the legacy parser worked. This is unexpected, please report this as a bug.\nThe legacy parser will be removed in the next major version."+        liftIO $ reportParseResult verbosity (extensionDescription key) fp lres+      (OldParser.ProjectParseFailed{}, Left{}) -> do+        -- 4. Both failed, report the original error. We don't check that the same errors are reported.+        liftIO $ reportParseResultParsec verbosity fp bs pres++reportParseResultParsec+  :: Verbosity+  -> FilePath+  -> BS.ByteString+  -> Parsec.ParseResult ProjectFileSource a+  -> IO a+reportParseResultParsec verbosity fpath contents pr = do+  let (warnings, result) = runParseResult pr+  case result of+    Right x -> do+      let sortKey p = (pwarningSource p, pwarningPosition (pwarning p))+          sortedWarnings = sortBy (comparing sortKey) warnings+      reportProjectParseWarnings verbosity fpath (map (showPWarningWithSource . fmap renderProjectFileSource) sortedWarnings)+      return x+    Left (_, errors) -> do+      dieWithException verbosity $ ProjectConfigParseFailure $ ProjectConfigParseError errors warnings++-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.+parseProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> FilePath -> IO (OldParser.ProjectParseResult ProjectConfigSkeleton)+parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout key extensionFile = do+  bs <- BS.readFile extensionFile+  res <- parseProject extensionFile (distDownloadSrcDirectory distDirLayout) httpTransport verbosity $ ProjectConfigToParse bs+  case res of+    x@(OldParser.ProjectParseOk _ skeleton) -> reportDuplicateImports verbosity skeleton >> pure x+    x@OldParser.ProjectParseFailed{} -> pure x++parseProjectFileSkeletonParsec :: Verbosity -> HttpTransport -> DistDirLayout -> ProjectFileKey -> FilePath -> IO (Parsec.ParseResult ProjectFileSource ProjectConfigSkeleton, BS.ByteString)+parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout key extensionFile = do+  bs <- BS.readFile extensionFile+  res <- Parsec.parseProject extensionFile (distDownloadSrcDirectory distDirLayout) httpTransport verbosity $ ProjectConfigToParse bs+  case snd $ runParseResult res of+    x@(Right skeleton) -> reportDuplicateImports verbosity skeleton >> pure (res, bs)+    x@Left{} -> pure (res, bs)+ -- | Render the 'ProjectConfig' format. -- -- For the moment this is implemented in terms of a pretty printer for the@@ -861,12 +1019,12 @@ -- | Write a @cabal.project.local@ file in the given project root dir. writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () writeProjectLocalExtraConfig DistDirLayout{distProjectFile} =-  writeProjectConfigFile (distProjectFile "local")+  writeProjectConfigFile (distProjectFile ProjectFileKeyLocal)  -- | Write a @cabal.project.freeze@ file in the given project root dir. writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} =-  writeProjectConfigFile (distProjectFile "freeze")+  writeProjectConfigFile (distProjectFile ProjectFileKeyFreeze)  -- | Write in the @cabal.project@ format to the given file. writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()@@ -877,27 +1035,31 @@ readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig readGlobalConfig verbosity configFileFlag = do   config <- liftIO (loadConfig verbosity configFileFlag)-  configFile <- liftIO (getConfigFilePath configFileFlag)+  configFile <- liftIO (getConfigFilePath verbosity configFileFlag)   monitorFiles [monitorFileHashed configFile]   return (convertLegacyGlobalConfig config) -reportProjectParseWarnings :: Verbosity -> FilePath -> [ProjectParseWarning] -> IO ()-reportProjectParseWarnings verbosity projectFile warnings =-  unless (null warnings) $-    let msgs =-          [ OldParser.showPWarning pFilename w-          | (p, w) <- warnings-          , let pFilename = fst $ unconsProjectConfigPath p-          ]-     in noticeDoc verbosity $-          vcat-            [ (text "Warnings found while parsing the project file" <> comma) <+> (text (takeFileName projectFile) <> colon)-            , cat [nest 1 $ text "-" <+> text m | m <- ordNub msgs]-            ]+reportProjectParseWarningsLegacy :: Verbosity -> FilePath -> [ProjectParseWarning] -> IO ()+reportProjectParseWarningsLegacy verbosity projectFile warnings =+  let msgs =+        [ OldParser.showPWarning pFilename w+        | (p, w) <- warnings+        , let pFilename = fst $ unconsProjectConfigPath p+        ]+   in reportProjectParseWarnings verbosity projectFile msgs +reportProjectParseWarnings :: Verbosity -> FilePath -> [String] -> IO ()+reportProjectParseWarnings verbosity projectFile msgs =+  unless (null msgs) $+    noticeDoc verbosity $+      vcat+        [ (text "Warnings found while parsing the project file" <> comma) <+> (text (takeFileName projectFile) <> colon)+        , cat [nest 1 $ text "-" <+> text m | m <- ordNub msgs]+        ]+ reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ProjectParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton reportParseResult verbosity _filetype projectFile (OldParser.ProjectParseOk warnings x) = do-  reportProjectParseWarnings verbosity projectFile warnings+  reportProjectParseWarningsLegacy verbosity projectFile warnings   return x reportParseResult verbosity filetype projectFile (OldParser.ProjectParseFailed (ProjectParseError snippet rootOrImportee err)) = do   let (line, msg) = OldParser.locatedErrorMsg err@@ -906,7 +1068,7 @@         maybe           (projectFile, empty)           ( \p ->-              ( fst $ unconsProjectConfigPath p+              ( currentProjectConfigPath p               , if isTopLevelConfigPath p then empty else docProjectConfigPath p               )           )@@ -958,7 +1120,7 @@  data BadPackageLocationMatch   = BadLocUnexpectedFile String-  | BadLocNonexistantFile String+  | BadLocNonexistentFile String   | BadLocDirNoCabalFile String   | BadLocDirManyCabalFiles String   deriving (Show)@@ -1051,7 +1213,7 @@       ++ "' is not recognised. The "       ++ "supported file targets are .cabal files, .tar.gz tarballs or package "       ++ "directories (i.e. directories containing a .cabal file)."-  BadLocNonexistantFile pkglocstr ->+  BadLocNonexistentFile pkglocstr ->     "The package location '" ++ pkglocstr ++ "' does not exist."   BadLocDirNoCabalFile pkglocstr ->     "The package directory '"@@ -1144,28 +1306,29 @@       checkIsFileGlobPackage pkglocstr =         case simpleParsec pkglocstr of           Nothing -> return Nothing-          Just glob -> liftM Just $ do-            matches <- matchFileGlob glob-            case matches of-              []-                | isJust (isTrivialRootedGlob glob) ->-                    return-                      ( Left-                          ( BadPackageLocationFile-                              (BadLocNonexistantFile pkglocstr)-                          )-                      )-              [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))-              _ -> do-                (failures, pkglocs) <--                  partitionEithers-                    <$> traverse checkFilePackageMatch matches-                return $! case (failures, pkglocs) of-                  ([failure], [])-                    | isJust (isTrivialRootedGlob glob) ->-                        Left (BadPackageLocationFile failure)-                  (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)-                  _ -> Right pkglocs+          Just glob ->+            Just <$> do+              matches <- matchFileGlob glob+              case matches of+                []+                  | isJust (isTrivialRootedGlob glob) ->+                      return+                        ( Left+                            ( BadPackageLocationFile+                                (BadLocNonexistentFile pkglocstr)+                            )+                        )+                [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))+                _ -> do+                  (failures, pkglocs) <-+                    partitionEithers+                      <$> traverse checkFilePackageMatch matches+                  return $! case (failures, pkglocs) of+                    ([failure], [])+                      | isJust (isTrivialRootedGlob glob) ->+                          Left (BadPackageLocationFile failure)+                    (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)+                    _ -> Right pkglocs        checkIsSingleFilePackage pkglocstr = do         let filename = distProjectRootDirectory </> pkglocstr@@ -1219,7 +1382,7 @@             | isFile ->                 return (Left (BadLocUnexpectedFile pkglocstr))             | parentDirExists ->-                return (Left (BadLocNonexistantFile pkglocstr))+                return (Left (BadLocNonexistentFile pkglocstr))             | otherwise ->                 return (Left (BadLocUnexpectedFile pkglocstr)) @@ -1388,10 +1551,10 @@     { distDownloadSrcDirectory     }   getTransport-  tarballUri =+  tarballUri = do     -- The tarball download is expensive so we use another layer of file     -- monitor to avoid it whenever possible.-    rerunIfChanged verbosity monitor tarballUri $ do+    r <- rerunIfChanged verbosity monitor tarballUri $ do       -- Download       transport <- getTransport       liftIO $ do@@ -1405,12 +1568,13 @@         return ()        -- Read-      monitorFiles [monitorFile tarballFile]       let location = RemoteTarballPackage tarballUri tarballFile       liftIO $         fmap (mkSpecificSourcePackage location)           . uncurry (readSourcePackageCabalFile verbosity)           =<< extractTarballPackageCabalFile tarballFile+    monitorFiles [monitorFile tarballFile]+    pure r     where       tarballStem :: FilePath       tarballStem =@@ -1545,7 +1709,7 @@               repoPaths            mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]-          mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))+          mapGroup = Map.toList . Map.fromListWith (<>) . map (second pure)            -- The repos in a group are given distinct names by simple enumeration           -- foo, foo-2, foo-3 etc@@ -1562,7 +1726,7 @@         let packageDir :: FilePath             packageDir = maybe repoPath (repoPath </>) (srpSubdir repo) -        entries <- liftIO $ getDirectoryContents packageDir+        entries <- liftIO $ listDirectory packageDir         -- TODO: dcoutts 2018-06-23: wrap exceptions         case filter (\e -> takeExtension e == ".cabal") entries of           [] -> liftIO $ throwIO $ NoCabalFileFound packageDir@@ -1602,43 +1766,6 @@       , srcpkgDescrOverride = Nothing       } --- | Errors reported upon failing to parse a @.cabal@ file.-data CabalFileParseError-  = CabalFileParseError-      FilePath-      -- ^ @.cabal@ file path-      BS.ByteString-      -- ^ @.cabal@ file contents-      (NonEmpty PError)-      -- ^ errors-      (Maybe Version)-      -- ^ We might discover the spec version the package needs-      [PWarning]-      -- ^ warnings---- | Manual instance which skips file contents-instance Show CabalFileParseError where-  showsPrec d (CabalFileParseError fp _ es mv ws) =-    showParen (d > 10) $-      showString "CabalFileParseError"-        . showChar ' '-        . showsPrec 11 fp-        . showChar ' '-        . showsPrec 11 ("" :: String)-        . showChar ' '-        . showsPrec 11 es-        . showChar ' '-        . showsPrec 11 mv-        . showChar ' '-        . showsPrec 11 ws--instance Exception CabalFileParseError where-  displayException = renderCabalFileParseError--renderCabalFileParseError :: CabalFileParseError -> String-renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) =-  renderParseError filePath contents errors warnings- -- | Wrapper for the @.cabal@ file parser. It reports warnings on higher -- verbosity levels and throws 'CabalFileParseError' on failure. readSourcePackageCabalFile@@ -1659,10 +1786,10 @@   -> BS.ByteString   -> IO GenericPackageDescription readSourcePackageCabalFile' logWarnings pkgfilename content =-  case runParseResult (parseGenericPackageDescription content) of+  case runParseResult (withSource (PCabalFile (pkgfilename, content)) $ parseGenericPackageDescription content) of     (warnings, Right pkg) -> do       unless (null warnings) $-        logWarnings (formatWarnings warnings)+        logWarnings (formatWarnings . map (fmap renderCabalFileSource) $ warnings)       return pkg     (warnings, Left (mspecVersion, errors)) ->       throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings@@ -1671,7 +1798,7 @@       "The package description file "         ++ pkgfilename         ++ " has warnings: "-        ++ unlines (map (showPWarning pkgfilename) warnings)+        ++ unlines (map showPWarningWithSource warnings)  -- | When looking for a package's @.cabal@ file we can find none, or several, -- both of which are failures.
+ src/Distribution/Client/ProjectConfig/FieldGrammar.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | 'ProjectConfig' Field descriptions+module Distribution.Client.ProjectConfig.FieldGrammar+  ( projectConfigFieldGrammar+  , packageConfigFieldGrammar+  ) where++import qualified Data.ByteString.Char8 as BS+import qualified Data.Set as Set+import Distribution.CabalSpecVersion (CabalSpecVersion (..))+import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGrammar)+import qualified Distribution.Client.ProjectConfig.Lens as L+import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..))+import Distribution.Client.Utils.Parsec+import Distribution.Compat.Prelude+import Distribution.FieldGrammar+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))+import Distribution.Solver.Types.ProjectConfigPath+import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))++projectConfigFieldGrammar :: ProjectConfigPath -> [String] -> ParsecFieldGrammar' ProjectConfig+projectConfigFieldGrammar source knownPrograms =+  ProjectConfig+    <$> monoidalFieldAla "packages" (alaList' FSep Token) L.projectPackages+    <*> monoidalFieldAla "optional-packages" (alaList' FSep Token) L.projectPackagesOptional+    <*> pure mempty -- source-repository-package stanza+    <*> monoidalFieldAla "extra-packages" formatPackageVersionConstraints L.projectPackagesNamed+    <*> blurFieldGrammar L.projectConfigBuildOnly projectConfigBuildOnlyFieldGrammar+    <*> blurFieldGrammar L.projectConfigShared (projectConfigSharedFieldGrammar source)+    <*> pure provenance+    <*> pure mempty+    -- \^ PackageConfig to be applied to all packages, specified inside 'package *' stanza+    <*> blurFieldGrammar L.projectConfigLocalPackages (packageConfigFieldGrammar knownPrograms)+    -- \^ PackageConfig to be applied to locally built packages, specified not inside a stanza+    <*> pure mempty+  where+    -- \^ PackageConfig applied to explicitly named packages+    provenance = Set.singleton (Explicit source)++formatPackageVersionConstraints :: [PackageVersionConstraint] -> List CommaVCat (Identity PackageVersionConstraint) PackageVersionConstraint+formatPackageVersionConstraints = alaList CommaVCat++projectConfigBuildOnlyFieldGrammar :: ParsecFieldGrammar' ProjectConfigBuildOnly+projectConfigBuildOnlyFieldGrammar =+  ProjectConfigBuildOnly+    <$> optionalFieldDef "verbose" L.projectConfigVerbosity mempty+    <*> pure mempty -- cli flag: projectConfigDryRun+    <*> pure mempty -- cli flag: projectConfigOnlyDeps+    <*> pure mempty -- cli flag: projectConfigOnlyDownload+    <*> monoidalFieldAla "build-summary" (alaNubList VCat) L.projectConfigSummaryFile+    <*> optionalFieldDef "build-log" L.projectConfigLogFile mempty+    <*> optionalFieldDef "remote-build-reporting" L.projectConfigBuildReports mempty+    <*> optionalFieldDef "report-planning-failure" L.projectConfigReportPlanningFailure mempty+    <*> optionalFieldDefAla "symlink-bindir" (alaFlag FilePathNT) L.projectConfigSymlinkBinDir mempty+    <*> optionalFieldDefAla "jobs" (alaFlag NumJobs) L.projectConfigNumJobs mempty+    <*> optionalFieldDef "semaphore" L.projectConfigUseSemaphore mempty+    <*> optionalFieldDef "keep-going" L.projectConfigKeepGoing mempty+    <*> optionalFieldDef "offline" L.projectConfigOfflineMode mempty+    <*> optionalFieldDef "haddock-keep-temp-files" L.projectConfigKeepTempFiles mempty+    <*> optionalFieldDefAla "http-transport" (alaFlag Token) L.projectConfigHttpTransport mempty+    <*> optionalFieldDef "ignore-expiry" L.projectConfigIgnoreExpiry mempty+    <*> optionalFieldDefAla "remote-repo-cache" (alaFlag FilePathNT) L.projectConfigCacheDir mempty+    <*> optionalFieldDefAla "logs-dir" (alaFlag FilePathNT) L.projectConfigLogsDir mempty+    <*> blurFieldGrammar L.projectConfigClientInstallFlags clientInstallFlagsGrammar++projectConfigSharedFieldGrammar :: ProjectConfigPath -> ParsecFieldGrammar' ProjectConfigShared+projectConfigSharedFieldGrammar source =+  ProjectConfigShared+    <$> optionalFieldDefAla "builddir" (alaFlag FilePathNT) L.projectConfigDistDir mempty+    <*> pure mempty -- cli flag: projectConfigConfigFile+    <*> optionalFieldDefAla "project-dir" (alaFlag FilePathNT) L.projectConfigProjectDir mempty+    <*> optionalFieldDefAla "project-file" (alaFlag FilePathNT) L.projectConfigProjectFile mempty+    <*> pure mempty -- You can't set the parser type in the project file.+    <*> optionalFieldDef "ignore-project" L.projectConfigIgnoreProject mempty+    <*> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty+    <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty+    <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty+    <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty+    <*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar+    <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs+    <*> pure mempty -- repository stanza for projectConfigRemoteRepos+    <*> pure mempty -- repository stanza for projectConfigLocalNoIndexRepos+    <*> monoidalField "active-repositories" L.projectConfigActiveRepos+    <*> monoidalField "index-state" L.projectConfigIndexState+    <*> optionalFieldDefAla "store-dir" (alaFlag FilePathNT) L.projectConfigStoreDir mempty+    <*> monoidalFieldAla "constraints" (alaList' FSep ProjectConstraints) L.projectConfigConstraints+      ^^^ (fmap . fmap) (\(userConstraint, _) -> (userConstraint, ConstraintSourceProjectConfig source))+    <*> monoidalFieldAla "preferences" formatPackageVersionConstraints L.projectConfigPreferences+    <*> optionalFieldDef "cabal-lib-version" L.projectConfigCabalVersion mempty+    <*> optionalFieldDef "solver" L.projectConfigSolver mempty+    <*> monoidalFieldAla "allow-older" AllowOlderNT L.projectConfigAllowOlder+    <*> monoidalFieldAla "allow-newer" AllowNewerNT L.projectConfigAllowNewer+    <*> optionalFieldDef "write-ghc-environment-files" L.projectConfigWriteGhcEnvironmentFilesPolicy mempty+    <*> optionalFieldDefAla "max-backjumps" (alaFlag MaxBackjumps) L.projectConfigMaxBackjumps mempty+    <*> optionalFieldDef "reorder-goals" L.projectConfigReorderGoals mempty+    <*> optionalFieldDef "count-conflicts" L.projectConfigCountConflicts mempty+    <*> optionalFieldDef "fine-grained-conflicts" L.projectConfigFineGrainedConflicts mempty+    <*> optionalFieldDef "minimize-conflict-set" L.projectConfigMinimizeConflictSet mempty+    <*> optionalFieldDef "strong-flags" L.projectConfigStrongFlags mempty+    <*> optionalFieldDef "allow-boot-library-installs" L.projectConfigAllowBootLibInstalls mempty+    <*> optionalFieldDef "reject-unconstrained-dependencies" L.projectConfigOnlyConstrained mempty+    <*> optionalFieldDef "per-component" L.projectConfigPerComponent mempty+    <*> optionalFieldDef "independent-goals" L.projectConfigIndependentGoals mempty+    <*> optionalFieldDef "prefer-oldest" L.projectConfigPreferOldest mempty+    <*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra+    <*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty++packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig+packageConfigFieldGrammar knownPrograms =+  mkPackageConfig+    <$> optionalFieldDef "haddock-all" noopLens mempty+      ^^^ hiddenField+    <*> pure mempty -- program-options stanza+    <*> pure mempty -- program-locations stanza+    <*> monoidalFieldAla "extra-prog-path" (alaNubList' FSep FilePathNT) L.packageConfigProgramPathExtra+    <*> monoidalField "flags" L.packageConfigFlagAssignment+    <*> optionalFieldDef "library-vanilla" L.packageConfigVanillaLib mempty+    <*> optionalFieldDef "shared" L.packageConfigSharedLib mempty+    <*> optionalFieldDef "static" L.packageConfigStaticLib mempty+    <*> optionalFieldDef "library-bytecode" L.packageConfigBytecodeLib mempty+    <*> optionalFieldDef "executable-dynamic" L.packageConfigDynExe mempty+    <*> optionalFieldDef "executable-static" L.packageConfigFullyStaticExe mempty+    <*> optionalFieldDef "profiling" L.packageConfigProf mempty+    <*> optionalFieldDef "library-profiling" L.packageConfigProfLib mempty+    <*> optionalFieldDef "profiling-shared" L.packageConfigProfShared mempty+    <*> optionalFieldDef "executable-profiling" L.packageConfigProfExe mempty+    <*> optionalFieldDef "profiling-detail" L.packageConfigProfDetail mempty+    <*> optionalFieldDef "library-profiling-detail" L.packageConfigProfLibDetail mempty+    <*> monoidalFieldAla "configure-options" (alaList' NoCommaFSep Token) L.packageConfigConfigureArgs+    <*> optionalFieldDef "optimization" L.packageConfigOptimization mempty+    <*> optionalFieldDef "program-prefix" L.packageConfigProgPrefix mempty+    <*> optionalFieldDef "program-suffix" L.packageConfigProgSuffix mempty+    <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.packageConfigExtraLibDirs+    <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.packageConfigExtraLibDirsStatic+    <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.packageConfigExtraFrameworkDirs+    <*> monoidalFieldAla "extra-include-dirs" (alaList' FSep FilePathNT) L.packageConfigExtraIncludeDirs+    <*> optionalFieldDef "library-for-ghci" L.packageConfigGHCiLib mempty+    <*> optionalFieldDef "split-sections" L.packageConfigSplitSections mempty+    <*> optionalFieldDef "split-objs" L.packageConfigSplitObjs mempty+    <*> optionalFieldDef "executable-stripping" L.packageConfigStripExes mempty+    <*> optionalFieldDef "library-stripping" L.packageConfigStripLibs mempty+    <*> optionalFieldDef "tests" L.packageConfigTests mempty+    <*> optionalFieldDef "benchmarks" L.packageConfigBenchmarks mempty+    <*> packageConfigCoverageGrammar+    <*> optionalFieldDef "relocatable" L.packageConfigRelocatable mempty+    <*> optionalFieldDef "debug-info" L.packageConfigDebugInfo mempty+    <*> optionalFieldDef "build-info" L.packageConfigDumpBuildInfo mempty+    <*> optionalFieldDef "run-tests" L.packageConfigRunTests mempty+    <*> optionalFieldDef "documentation" L.packageConfigDocumentation mempty+    <*> optionalFieldDef "haddock-hoogle" L.packageConfigHaddockHoogle mempty+    <*> optionalFieldDef "haddock-html" L.packageConfigHaddockHtml mempty+    <*> optionalFieldDefAla "haddock-html-location" (alaFlag Token) L.packageConfigHaddockHtmlLocation mempty+    <*> optionalFieldDef "haddock-foreign-libraries" L.packageConfigHaddockForeignLibs mempty+    <*> optionalFieldDef "haddock-executables" L.packageConfigHaddockExecutables mempty+    <*> optionalFieldDef "haddock-tests" L.packageConfigHaddockTestSuites mempty+    <*> optionalFieldDef "haddock-benchmarks" L.packageConfigHaddockBenchmarks mempty+    <*> optionalFieldDef "haddock-internal" L.packageConfigHaddockInternal mempty+    <*> optionalFieldDefAla "haddock-css" (alaFlag FilePathNT) L.packageConfigHaddockCss mempty+    <*> optionalFieldDef "haddock-hyperlink-source" L.packageConfigHaddockLinkedSource mempty+    <*> optionalFieldDef "haddock-quickjump" L.packageConfigHaddockQuickJump mempty+    <*> optionalFieldDefAla "haddock-hscolour-css" (alaFlag FilePathNT) L.packageConfigHaddockHscolourCss mempty+    <*> optionalFieldDef "haddock-contents-location" L.packageConfigHaddockContents mempty+    <*> optionalFieldDef "haddock-index-location" L.packageConfigHaddockIndex mempty+    <*> optionalFieldDefAla "haddock-base-url" (alaFlag Token) L.packageConfigHaddockBaseUrl mempty+    <*> optionalFieldDefAla "haddock-resources-dir" (alaFlag Token) L.packageConfigHaddockResourcesDir mempty+    <*> optionalFieldDefAla "haddock-output-dir" (alaFlag FilePathNT) L.packageConfigHaddockOutputDir mempty+    <*> optionalFieldDef "haddock-use-unicode" L.packageConfigHaddockUseUnicode mempty+    <*> optionalFieldDef "haddock-for-hackage" L.packageConfigHaddockForHackage mempty+    <*> optionalFieldDef "test-log" L.packageConfigTestHumanLog mempty+    <*> optionalFieldDef "test-machine-log" L.packageConfigTestMachineLog mempty+    <*> optionalFieldDef "test-show-details" L.packageConfigTestShowDetails mempty+    <*> optionalFieldDef "test-keep-tix-files" L.packageConfigTestKeepTix mempty+    <*> optionalFieldDefAla "test-wrapper" (alaFlag FilePathNT) L.packageConfigTestWrapper mempty+    <*> optionalFieldDef "test-fail-when-no-test-suites" L.packageConfigTestFailWhenNoTestSuites mempty+    <*> monoidalFieldAla "test-options" (alaList NoCommaFSep) L.packageConfigTestTestOptions+    <*> monoidalFieldAla "benchmark-options" (alaList NoCommaFSep) L.packageConfigBenchmarkOptions+    -- A PackageConfig may contain -options and -location fields inside a package * (projectConfigAllPackages) or package <name> stanza (packageConfigSpecificPackage).+    -- When declared at top level (packageConfigLocalPackages), the PackageConfig must contain a program-options stanza/program-locations for these fields.+    <* traverse_ (knownField . BS.pack . (<> "-options")) knownPrograms+    <* traverse_ (knownField . BS.pack . (<> "-location")) knownPrograms+  where+    noopLens f s = s <$ f mempty+    mkPackageConfig+      haddockAll+      packageConfigProgramPaths+      packageConfigProgramArgs+      packageConfigProgramPathExtra+      packageConfigFlagAssignment+      packageConfigVanillaLib+      packageConfigSharedLib+      packageConfigStaticLib+      packageConfigBytecodeLib+      packageConfigDynExe+      packageConfigFullyStaticExe+      packageConfigProf+      packageConfigProfLib+      packageConfigProfShared+      packageConfigProfExe+      packageConfigProfDetail+      packageConfigProfLibDetail+      packageConfigConfigureArgs+      packageConfigOptimization+      packageConfigProgPrefix+      packageConfigProgSuffix+      packageConfigExtraLibDirs+      packageConfigExtraLibDirsStatic+      packageConfigExtraFrameworkDirs+      packageConfigExtraIncludeDirs+      packageConfigGHCiLib+      packageConfigSplitSections+      packageConfigSplitObjs+      packageConfigStripExes+      packageConfigStripLibs+      packageConfigTests+      packageConfigBenchmarks+      packageConfigCoverage+      packageConfigRelocatable+      packageConfigDebugInfo+      packageConfigDumpBuildInfo+      packageConfigRunTests+      packageConfigDocumentation+      packageConfigHaddockHoogle+      packageConfigHaddockHtml+      packageConfigHaddockHtmlLocation+      packageConfigHaddockForeignLibs'+      packageConfigHaddockExecutables'+      packageConfigHaddockTestSuites'+      packageConfigHaddockBenchmarks'+      packageConfigHaddockInternal+      packageConfigHaddockCss+      packageConfigHaddockLinkedSource+      packageConfigHaddockQuickJump+      packageConfigHaddockHscolourCss+      packageConfigHaddockContents+      packageConfigHaddockIndex+      packageConfigHaddockBaseUrl+      packageConfigHaddockResourcesDir+      packageConfigHaddockOutputDir+      packageConfigHaddockUseUnicode+      packageConfigHaddockForHackage+      packageConfigTestHumanLog+      packageConfigTestMachineLog+      packageConfigTestShowDetails+      packageConfigTestKeepTix+      packageConfigTestWrapper+      packageConfigTestFailWhenNoTestSuites+      packageConfigTestTestOptions+      packageConfigBenchmarkOptions =+        PackageConfig+          { -- The haddock-al` field provides a default value, but explicit declarations can override it+            packageConfigHaddockForeignLibs = haddockAll <> packageConfigHaddockForeignLibs'+          , packageConfigHaddockExecutables = haddockAll <> packageConfigHaddockExecutables'+          , packageConfigHaddockTestSuites = haddockAll <> packageConfigHaddockTestSuites'+          , packageConfigHaddockBenchmarks = haddockAll <> packageConfigHaddockBenchmarks'+          , ..+          }++packageConfigCoverageGrammar :: ParsecFieldGrammar PackageConfig (Distribution.Simple.Flag.Flag Bool)+packageConfigCoverageGrammar =+  (<>)+    <$> optionalFieldDef "coverage" L.packageConfigCoverage mempty+    <*> optionalFieldDef "library-coverage" L.packageConfigCoverage mempty+      ^^^ deprecatedSince CabalSpecV1_22 "Please use 'coverage' field instead."
+ src/Distribution/Client/ProjectConfig/Import.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Project configuration imports.+module Distribution.Client.ProjectConfig.Import+  ( -- * Parsing skeleton+    ProjectConfigSkeleton+  , projectSkeletonImports+  , fetchImport++    -- * Messages+  , docProjectConfigFiles+  , cyclicalImportMsg+  , untrimmedUriImportMsg++    -- * Checks+  , reportDuplicateImports+  ) where++import Control.Arrow (Kleisli (..), arr, second, (>>>))+import qualified Data.ByteString.Char8 as BS+import Data.Coerce (coerce)+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.List ((\\))+import qualified Data.Map as Map+import Distribution.Client.Compat.Prelude hiding (empty, (<>))+import qualified Distribution.Client.Compat.Prelude as Prelude ((<>))+import Distribution.Client.HttpUtils+import Distribution.Client.ProjectConfig.Types+import Distribution.Compat.Lens (view)+import Distribution.PackageDescription (ConfVar (..))+import Distribution.Simple.Utils (debug, noticeDoc, ordNub)+import Distribution.Solver.Types.ProjectConfigPath+import Distribution.Types.CondTree (CondTree (..), traverseCondTreeA)+import Distribution.Utils.String (trim)+import Network.URI (URI (..), parseURI)+import System.Directory (createDirectoryIfMissing)+import System.FilePath (isAbsolute, isPathSeparator, makeValid, (</>))+import Text.PrettyPrint (Doc, empty, int, nest, semi, text, vcat, (<>))++-- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping+-- a config. It can be finalized by providing the conditional resolution info+-- and then resolving and downloading the imports+type ProjectConfigSkeleton = CondTree ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)++projectSkeletonImports :: ProjectConfigSkeleton -> [(Maybe URI, ProjectConfigPath)]+projectSkeletonImports = fst . view traverseCondTreeA++-- | Fetch a local file import or remote URL import and parse it.+fetchImport+  :: (ProjectConfigToParse -> IO a)+  -> FilePath+  -> HttpTransport+  -> Verbosity+  -> FilePath+  -> ProjectConfigPath+  -> IO (Maybe URI, a)+fetchImport parser cacheDir httpTransport verbosity projectDir normLocPath =+  fetchImportConfig normLocPath >>= runKleisli (second (arr ProjectConfigToParse >>> Kleisli parser))+  where+    fetchImportConfig :: ProjectConfigPath -> IO (Maybe URI, BS.ByteString)+    fetchImportConfig (ProjectConfigPath (pci :| _)) = do+      debug verbosity $ "fetching import: " ++ pci+      let mbUri = parseURI (trim pci)+      (mbUri,) <$> case mbUri of+        Just uri -> do+          let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)+          createDirectoryIfMissing True cacheDir+          _ <- downloadURI httpTransport verbosity uri fp+          BS.readFile fp+        Nothing ->+          BS.readFile $+            if isAbsolute pci then pci else coerce projectDir </> pci++-- | Not just any file path. The project itself.+newtype ProjectFilePath = ProjectFilePath FilePath+  deriving (Eq, Generic)++-- | Isomorphic with 'ProjectConfigPath' but with separate constructors for the+-- root, imported file and imported URI.+data ProjectNode a where+  ProjectRoot :: FilePath -> ProjectNode ProjectFilePath+  ProjectFileImport :: FilePath -> ProjectConfigPath -> ProjectNode FilePath+  ProjectUriImport :: URI -> ProjectConfigPath -> ProjectNode URI++instance Eq (ProjectNode a) where+  (==) a b+    | ProjectRoot root <- a+    , ProjectRoot root' <- b =+        root == root'+    | ProjectFileImport importOf importBy <- a+    , ProjectFileImport importOf' importBy' <- b =+        (==)+          (consProjectConfigPath importOf importBy)+          (consProjectConfigPath importOf' importBy')+    | ProjectUriImport importOf importBy <- a+    , ProjectUriImport importOf' importBy' <- b =+        (==)+          (consProjectConfigPath (show importOf) importBy)+          (consProjectConfigPath (show importOf') importBy')++instance Pretty (ProjectNode a) where+  pretty = \case+    ProjectRoot root -> text root+    ProjectFileImport importOf importBy -> pretty $ consProjectConfigPath importOf importBy+    ProjectUriImport importOf importBy -> pretty $ consProjectConfigPath (show importOf) importBy++instance Show (ProjectNode a) where show = prettyShow++-- | Sorts the same as 'ProjectConfigPath' does.+instance Ord (ProjectNode a) where+  compare =+    (compare :: ProjectConfigPath -> ProjectConfigPath -> Ordering)+      `on` ( \case+              ProjectRoot root -> ProjectConfigPath $ root :| []+              ProjectFileImport importOf importBy -> consProjectConfigPath importOf importBy+              ProjectUriImport importOf importBy -> consProjectConfigPath (show importOf) importBy+           )++-- | Renders the paths as a list without showing which path imports another,+-- like this;+--+-- >- cabal.project+-- >- project-cabal/constraints.config+-- >- project-cabal/ghc-latest.config+-- >- project-cabal/ghc-options.config+-- >- project-cabal/pkgs.config+-- >- project-cabal/pkgs/benchmarks.config+-- >- project-cabal/pkgs/buildinfo.config+-- >- project-cabal/pkgs/cabal.config+-- >- project-cabal/pkgs/install.config+-- >- project-cabal/pkgs/integration-tests.config+-- >- project-cabal/pkgs/tests.config+--+--+-- >>> :{+--   do+--     let ps =+--              [ ProjectConfigPath ("cabal.project" :| [])+--              , ProjectConfigPath ("project-cabal/constraints.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/ghc-latest.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/ghc-options.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/benchmarks.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/buildinfo.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/cabal.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/install.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/integration-tests.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/tests.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              ]+--     return . render $ docProjectConfigFiles ps+-- :}+-- "- cabal.project\n- project-cabal/constraints.config\n- project-cabal/ghc-latest.config\n- project-cabal/ghc-options.config\n- project-cabal/pkgs.config\n- project-cabal/pkgs/benchmarks.config\n- project-cabal/pkgs/buildinfo.config\n- project-cabal/pkgs/cabal.config\n- project-cabal/pkgs/install.config\n- project-cabal/pkgs/integration-tests.config\n- project-cabal/pkgs/tests.config"+--+-- The listing puts projects first, URLs last and sorts the other paths+-- lexically, dropping any duplicates, like this:+--+-- >- cabal.project+-- >- 0.config+-- >- 2.config+-- >- cfg/1.config+-- >- cfg/3.config+-- >- with-ghc.config+-- >- https://www.stackage.org/lts-21.25/cabal.config+--+-- >>> let p = ProjectConfigPath $ "cabal.project" :| []+-- >>> let a = ProjectConfigPath $ "0.config" :| ["cabal.project"]+-- >>> let b = ProjectConfigPath $ "cfg/1.config" :| ["0.config", "cabal.project"]+-- >>> let c = ProjectConfigPath $ "with.config" :| ["0.config", "cabal.project"]+-- >>> let d = ProjectConfigPath $ "2.config" :| ["cfg/1.config", "0.config", "cabal.project"]+-- >>> let e = ProjectConfigPath $ "cfg/3.config" :| ["2.config", "cfg/1.config", "0.config", "cabal.project"]+-- >>> let f = ProjectConfigPath $ "https://www.stackage.org/lts-21.25/cabal.config" :| ["2.config", "cfg/1.config", "0.config", "cabal.project"]+-- >>> let g = ProjectConfigPath $ "https://www.stackage.org/lts-21.25/cabal.config" :| ["cfg/3.config", "2.config", "cfg/1.config", "0.config", "cabal.project"]+-- >>> let ps = [p, a, b, c, d, e, f, g]+-- >>> render $ docProjectConfigFiles ps+-- "- cabal.project\n- 0.config\n- 2.config\n- cfg/1.config\n- cfg/3.config\n- with.config\n- https://www.stackage.org/lts-21.25/cabal.config"+docProjectConfigFiles :: [ProjectConfigPath] -> Doc+docProjectConfigFiles (sortBy compareLexicographically -> ps) =+  vcat+    [ text "-" <+> text p+    | p <- ordNub [p | ProjectConfigPath (p :| _) <- ps]+    ]++-- | A message for a cyclical import, a "cyclical import of".+cyclicalImportMsg :: ProjectConfigPath -> Doc+cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =+  seenImportMsg+    (text "cyclical import of" <+> text duplicate <> semi)+    (ProjectFileImport duplicate path)+    []++-- | A message for a duplicate import, a "duplicate import of". If a check for+-- cyclical imports has already been made then this would report a duplicate+-- import by two different paths.+duplicateImportMsg :: Doc -> ProjectNode a -> [ProjectNode a] -> Doc+duplicateImportMsg intro = seenImportMsg intro++seenImportMsg :: Doc -> ProjectNode a -> [ProjectNode a] -> Doc+seenImportMsg intro projectNode seenImports =+  vcat+    [ intro+    , maybe empty (nest 2 . docProjectConfigPath) path+    , nest 2 $+        vcat+          [ docProjectConfigPath i+          | Just i <- importBy <$> filter ((duplicate ==) . importOf) seenImports+          ]+    ]+  where+    duplicate = importOf projectNode+    path = importBy projectNode++    importOf :: ProjectNode a -> FilePath+    importOf = \case+      ProjectRoot dup -> dup+      ProjectFileImport dup _ -> dup+      ProjectUriImport dup _ -> show dup++    importBy :: ProjectNode a -> Maybe ProjectConfigPath+    importBy = \case+      ProjectRoot _ -> Nothing+      ProjectFileImport _ by -> Just by+      ProjectUriImport _ by -> Just by++-- | A message for an import that has leading or trailing spaces.+untrimmedUriImportMsg :: Doc -> ProjectConfigPath -> Doc+untrimmedUriImportMsg intro path =+  vcat+    [ intro <+> text "import has leading or trailing whitespace" <> semi+    , nest 2 (docProjectConfigPath path)+    ]++-- | Detect and report any duplicate imports, including those missed when parsing.+--+-- Parsing catches cyclical imports and some but not all duplicate imports. In+-- particular, it doesn't catch when the same project configuration is imported+-- via different import paths.+reportDuplicateImports :: Verbosity -> ProjectConfigSkeleton -> IO ()+reportDuplicateImports verbosity skeleton = do+  let (dupeRoots, dupeFiles, dupeUris) = detectDupes $ projectSkeletonImports skeleton+  unless (Map.null dupeRoots) (noticeDoc verbosity $ vcat (dupesMsg <$> Map.toList dupeRoots))+  unless (Map.null dupeFiles) (noticeDoc verbosity $ vcat (dupesMsg <$> Map.toList dupeFiles))+  unless (Map.null dupeUris) (noticeDoc verbosity $ vcat (dupesMsg <$> Map.toList dupeUris))++toDupes :: Ord k => [(k, [ProjectNode a])] -> Map k [Dupes a]+toDupes xs =+  xs+    & Map.fromListWith (Prelude.<>)+    & Map.filter ((> 1) . length)+    <&> \ys -> [Dupes v ys | v <- ys]++detectDupes :: [(Maybe URI, ProjectConfigPath)] -> (DupesMap ProjectFilePath, DupesMap FilePath, DupesMap URI)+detectDupes xs = (toDupes roots, toDupes files, toDupes uris)+  where+    (<$$>) = fmap . fmap+    roots =+      [ (h, [ProjectRoot h])+      | (Nothing, (h, Nothing)) <- unconsProjectConfigPath <$$> xs+      ]+    files =+      [ (h, [ProjectFileImport h (consProjectConfigPath h t)])+      | (Nothing, (h, Just t)) <- unconsProjectConfigPath <$$> xs+      ]+    uris =+      [ (f, [ProjectUriImport u (consProjectConfigPath f t)])+      | (Just u, (f, Just t)) <- unconsProjectConfigPath <$$> xs+      , show u == f+      ]++data Dupes a = Dupes+  { dupesImport :: ProjectNode a+  -- ^ The import that we're checking for duplicates.+  , dupesImports :: [ProjectNode a]+  -- ^ All the imports of this file.+  }+  deriving (Eq)++instance Ord (Dupes a) where+  compare x y =+    (compare `on` length . dupesImports) x y+      `thenCmp` (compare `on` sort . dupesImports) x y+      `thenCmp` (compare `on` dupesImport) x y+    where+      thenCmp :: Ordering -> Ordering -> Ordering+      thenCmp EQ o2 = o2+      thenCmp o1 _ = o1++type DupesMap a = Map FilePath [Dupes a]++dupesMsg :: (FilePath, [Dupes a]) -> Doc+dupesMsg (duplicate, ds@(take 1 . sort -> dupes)) =+  vcat $+    ((text "Warning:" <+> int (length ds) <+> text "imports of" <+> text duplicate) <> semi)+      : ((\Dupes{..} -> duplicateImportMsg empty dupesImport (sort $ dupesImports \\ [dupesImport])) <$> dupes)++-- $setup+-- >>> import Text.PrettyPrint (render)
src/Distribution/Client/ProjectConfig/Legacy.hs view
@@ -1,41 +1,41 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}  -- | Project configuration, implementation in terms of legacy types. module Distribution.Client.ProjectConfig.Legacy-  ( -- Project config skeletons+  ( -- * Skeletons     ProjectConfigSkeleton-  , parseProject   , instantiateProjectConfigSkeletonFetchingCompiler   , instantiateProjectConfigSkeletonWithCompiler   , singletonProjectConfigSkeleton-  , projectSkeletonImports -    -- * Project config in terms of legacy types-  , LegacyProjectConfig+    -- * Parsing+  , parseProject   , parseLegacyProjectConfig++    -- * Legacy Configuration+  , LegacyProjectConfig   , showLegacyProjectConfig -    -- * Conversion to and from legacy config types+    -- * Conversions   , commandLineFlagsToProjectConfig   , convertLegacyProjectConfig   , convertLegacyGlobalConfig   , convertToLegacyProjectConfig -    -- * Internals, just for tests+    -- * Internals++    -- | These functions are exposed just for tests.   , parsePackageLocationTokenQ   , renderPackageLocationToken   ) where -import Data.Coerce (coerce) import Distribution.Client.Compat.Prelude  import Distribution.Types.Flag (FlagName, parsecFlagAssignment)@@ -58,12 +58,13 @@   , defaultClientInstallFlags   ) -import Distribution.Compat.Lens (toListOf, view)+import Distribution.Compat.Lens (toListOf)  import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.ProjectConfigPath  import Distribution.Client.NixStyleOptions (NixStyleFlags (..))+import Distribution.Client.ProjectConfig.Import (ProjectConfigSkeleton, cyclicalImportMsg, fetchImport, untrimmedUriImportMsg) import Distribution.Client.ProjectFlags (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) import Distribution.Client.Setup   ( ConfigExFlags (..)@@ -140,7 +141,7 @@   , CondTree (..)   , ignoreConditions   , mapTreeConds-  , traverseCondTreeC+  , mapTreeData   , traverseCondTreeV   ) import Distribution.Types.SourceRepo (RepoType)@@ -149,7 +150,6 @@   , overNubList   , toNubList   )-import Distribution.Utils.String (trim)  import Distribution.Client.HttpUtils import Distribution.Client.ParseUtils@@ -200,9 +200,9 @@ import Data.Functor ((<&>)) import qualified Data.Map as Map import qualified Data.Set as Set-import Network.URI (URI (..), nullURIAuth, parseURI)-import System.Directory (createDirectoryIfMissing, makeAbsolute)-import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, (</>))+import Network.URI (URI (..), nullURIAuth)+import System.Directory (makeAbsolute)+import System.FilePath (splitFileName) import Text.PrettyPrint   ( Doc   , render@@ -214,16 +214,12 @@ -- Handle extended project config files with conditionals and imports. -- --- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping a config. It can be finalized by providing the conditional resolution info--- and then resolving and downloading the imports-type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigPath] ProjectConfig- singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton-singletonProjectConfigSkeleton x = CondNode x mempty mempty+singletonProjectConfigSkeleton x = CondNode (mempty, x) mempty  instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, Compiler) -> FlagAssignment -> ProjectConfigSkeleton -> m (ProjectConfig, Maybe Compiler) instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel-  | null (toListOf traverseCondTreeV skel) = pure (fst (ignoreConditions skel), Nothing)+  | null (toListOf traverseCondTreeV skel) = pure (ignoreConditions $ mapTreeData snd skel, Nothing)   | otherwise = do       (os, arch, comp) <- fetch       let conf = instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo comp) flags skel@@ -232,23 +228,15 @@ instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel   where-    go-      :: CondTree-          FlagName-          [ProjectConfigPath]-          ProjectConfig-      -> ProjectConfig-    go (CondNode l _imps ts) =+    go :: CondTree FlagName ([(Maybe URI, ProjectConfigPath)], ProjectConfig) -> ProjectConfig+    go (CondNode (_, l) ts) =       let branches = concatMap processBranch ts        in l <> mconcat branches     processBranch (CondBranch cnd t mf) = case cnd of       (Lit True) -> [go t]-      (Lit False) -> maybe ([]) ((: []) . go) mf+      (Lit False) -> maybe [] ((: []) . go) mf       _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer -projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigPath]-projectSkeletonImports = view traverseCondTreeC- -- | Parses a project from its root config file, typically cabal.project. parseProject   :: FilePath@@ -265,8 +253,10 @@     projectDir <- makeAbsolute dir     projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])     parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse-    -- NOTE: Reverse the warnings so they are in line number order.-    <&> \case ProjectParseOk ws x -> ProjectParseOk (reverse ws) x; x -> x+    <&> \case+      -- NOTE: Reverse the warnings so they are in line number order.+      ProjectParseOk ws skeleton -> ProjectParseOk (reverse ws) skeleton+      x@ProjectParseFailed{} -> x  parseProjectSkeleton   :: FilePath@@ -298,9 +288,10 @@             when               (isUntrimmedUriConfigPath importLocPath)               (noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)-            let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)-            res <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath+            let parser = parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath+            (mbUri, res) <- fetchImport parser cacheDir httpTransport verbosity projectDir normLocPath             rest <- go [] xs+            let fs = (\z -> CondNode ([(mbUri, normLocPath)], z) mempty) <$> fieldsToConfig normSource (reverse acc)             pure . fmap mconcat . sequence $ [projectParse Nothing normSource fs, res, rest]       (ParseUtils.Section l "if" p xs') -> do         normSource <- canonicalizeConfigPath projectDir source@@ -308,7 +299,7 @@         let fs = singletonProjectConfigSkeleton <$> fieldsToConfig source (reverse acc)         (elseClauses, rest) <- parseElseClauses xs         let condNode =-              (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])+              (\c pcs e -> CondNode mempty [CondBranch c pcs e])                 <$>                 -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused                 ( let s = "if(" <> p <> ")"@@ -333,14 +324,14 @@         subpcs <- go [] xs'         (elseClauses, rest) <- parseElseClauses xs         let condNode =-              (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])+              (\c pcs e -> CondNode mempty [CondBranch c pcs e])                 <$> ( let s = "elif(" <> p <> ")"                        in projectParse (Just s) normSource (adaptParseError l (parseConditionConfVarFromClause $ BS.pack s))                     )                 <*> subpcs                 <*> elseClauses         pure (Just <$> condNode, rest)-      _ -> (\r -> (pure Nothing, r)) <$> go [] x+      _ -> (pure Nothing,) <$> go [] x      -- We want a normalized path for @fieldsToConfig@. This eventually surfaces     -- in solver rejection messages and build messages "this build was affected@@ -365,36 +356,19 @@         addWarnings (ProjectParseOk ws' x') = ProjectParseOk (ws' ++ ((p,) <$> ws)) x'         addWarnings x' = x'     liftPR p _ (ParseFailed e) = pure $ projectParseFail Nothing (Just p) e--    fetchImportConfig :: ProjectConfigPath -> IO BS.ByteString-    fetchImportConfig (ProjectConfigPath (pci :| _)) = do-      debug verbosity $ "fetching import: " ++ pci-      fetch pci--    fetch :: FilePath -> IO BS.ByteString-    fetch pci = case parseURI $ trim pci of-      Just uri -> do-        let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)-        createDirectoryIfMissing True cacheDir-        _ <- downloadURI httpTransport verbosity uri fp-        BS.readFile fp-      Nothing ->-        BS.readFile $-          if isAbsolute pci then pci else coerce projectDir </> pci-     modifiesCompiler :: ProjectConfig -> Bool     modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg       where         isSet f = f (projectConfigShared pc) /= NoFlag      sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ProjectParseResult ProjectConfigSkeleton-    sanityWalkPCS underConditional t@(CondNode d (listToMaybe -> c) comps)+    sanityWalkPCS underConditional t@(CondNode (fmap snd . listToMaybe -> c, d) comps)       | underConditional && modifiesCompiler d =           projectParseFail Nothing c $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing       | otherwise =           mapM_ sanityWalkBranch comps >> pure t -    sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ProjectParseResult ()+    sanityWalkBranch :: CondBranch ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig) -> ProjectParseResult ()     sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()  ------------------------------------------------------------------@@ -771,6 +745,7 @@       { flagProjectDir = projectConfigProjectDir       , flagProjectFile = projectConfigProjectFile       , flagIgnoreProject = projectConfigIgnoreProject+      , flagProjectFileParser = projectConfigProjectFileParser       } = projectFlags  -- | Helper used by other conversion functions that returns the@@ -798,6 +773,7 @@         , configProfLib = packageConfigProfLib         , configSharedLib = packageConfigSharedLib         , configStaticLib = packageConfigStaticLib+        , configBytecodeLib = packageConfigBytecodeLib         , configDynExe = packageConfigDynExe         , configFullyStaticExe = packageConfigFullyStaticExe         , configProfExe = packageConfigProfExe@@ -983,6 +959,7 @@       globalFlags =         GlobalFlags           { globalVersion = mempty+          , globalFullVersion = mempty           , globalNumericVersion = mempty           , globalConfigFile = projectConfigConfigFile           , globalConstraintsFile = mempty@@ -993,7 +970,6 @@           , globalLogsDir = projectConfigLogsDir           , globalIgnoreExpiry = projectConfigIgnoreExpiry           , globalHttpTransport = projectConfigHttpTransport-          , globalNix = mempty           , globalStoreDir = projectConfigStoreDir           , globalProgPathExtra = projectConfigProgPathExtra           }@@ -1001,7 +977,7 @@       commonFlags =         mempty           { setupVerbosity = projectConfigVerbosity-          , setupDistPref = fmap makeSymbolicPath $ projectConfigDistDir+          , setupDistPref = fmap makeSymbolicPath projectConfigDistDir           , setupKeepTempFiles = projectConfigKeepTempFiles           } @@ -1070,6 +1046,7 @@           { flagProjectDir = projectConfigProjectDir           , flagProjectFile = projectConfigProjectFile           , flagIgnoreProject = projectConfigIgnoreProject+          , flagProjectFileParser = projectConfigProjectFileParser           }  convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig@@ -1147,6 +1124,7 @@           , configAllowDependingOnPrivateLibs = mempty           , configCoverageFor = mempty           , configIgnoreBuildTools = mempty+          , configBytecodeLib = mempty           }        haddockFlags =@@ -1179,6 +1157,7 @@         , configProfLib = packageConfigProfLib         , configSharedLib = packageConfigSharedLib         , configStaticLib = packageConfigStaticLib+        , configBytecodeLib = packageConfigBytecodeLib         , configDynExe = packageConfigDynExe         , configFullyStaticExe = packageConfigFullyStaticExe         , configProfExe = packageConfigProfExe@@ -1199,13 +1178,13 @@         , configSplitObjs = packageConfigSplitObjs         , configStripExes = packageConfigStripExes         , configStripLibs = packageConfigStripLibs-        , configExtraLibDirs = fmap makeSymbolicPath $ packageConfigExtraLibDirs-        , configExtraLibDirsStatic = fmap makeSymbolicPath $ packageConfigExtraLibDirsStatic-        , configExtraFrameworkDirs = fmap makeSymbolicPath $ packageConfigExtraFrameworkDirs+        , configExtraLibDirs = fmap makeSymbolicPath packageConfigExtraLibDirs+        , configExtraLibDirsStatic = fmap makeSymbolicPath packageConfigExtraLibDirsStatic+        , configExtraFrameworkDirs = fmap makeSymbolicPath packageConfigExtraFrameworkDirs         , configConstraints = mempty         , configDependencies = mempty         , configPromisedDependencies = mempty-        , configExtraIncludeDirs = fmap makeSymbolicPath $ packageConfigExtraIncludeDirs+        , configExtraIncludeDirs = fmap makeSymbolicPath packageConfigExtraIncludeDirs         , configIPID = mempty         , configCID = mempty         , configDeterministic = mempty@@ -1345,18 +1324,18 @@ -- allow http urls which don't parse as globs, and possibly some -- system-dependent file paths. So we parse fairly liberally as a token, but -- we allow @,@ inside matched @{}@ braces.-parsePackageLocationTokenQ :: ReadP r String+parsePackageLocationTokenQ :: ReadP String parsePackageLocationTokenQ =   parseHaskellString     Parse.<++ parsePackageLocationToken   where-    parsePackageLocationToken :: ReadP r String+    parsePackageLocationToken :: ReadP String     parsePackageLocationToken = fmap fst (Parse.gather outerTerm)       where         outerTerm = alternateEither1 outerToken (braces innerTerm)         innerTerm = alternateEither innerToken (braces innerTerm)-        outerToken = Parse.munch1 outerChar >> return ()-        innerToken = Parse.munch1 innerChar >> return ()+        outerToken = void $ Parse.munch1 outerChar+        innerToken = void $ Parse.munch1 innerChar         outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')         innerChar c = not (isSpace c || c == '{' || c == '}')         braces = Parse.between (Parse.char '{') (Parse.char '}')@@ -1367,7 +1346,7 @@       , alternate1PQs       , alternateQsP       , alternate1QsP-        :: ReadP r () -> ReadP r () -> ReadP r ()+        :: ReadP () -> ReadP () -> ReadP ()      alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p     alternateEither p q = alternateEither1 p q +++ return ()@@ -1443,7 +1422,7 @@           [ commaNewLineListFieldParsec               "constraints"               (pretty . fst)-              (fmap (\constraint -> (constraint, constraintSrc)) parsec)+              (fmap (,constraintSrc) parsec)               configExConstraints               (\v conf -> conf{configExConstraints = v})           , commaNewLineListFieldParsec@@ -1582,6 +1561,7 @@         , "library-vanilla"         , "library-profiling"         , "library-vanilla"+        , "library-bytecode"         , "shared"         , "static"         , "executable-dynamic"@@ -1719,7 +1699,7 @@         $ let name = "build-info"            in FieldDescr                 name-                ( \f -> case f of+                ( \case                     Flag NoDumpBuildInfo -> Disp.text "False"                     Flag DumpBuildInfo -> Disp.text "True"                     _ -> Disp.empty@@ -1747,7 +1727,7 @@         $ let name = "optimization"            in FieldDescr                 name-                ( \f -> case f of+                ( \case                     Flag NoOptimisation -> Disp.text "False"                     Flag NormalOptimisation -> Disp.text "True"                     Flag MaximumOptimisation -> Disp.text "2"@@ -1772,7 +1752,7 @@         let name = "debug-info"          in FieldDescr               name-              ( \f -> case f of+              ( \case                   Flag NoDebugInfo -> Disp.text "False"                   Flag MinimalDebugInfo -> Disp.text "1"                   Flag NormalDebugInfo -> Disp.text "True"@@ -1804,7 +1784,6 @@  legacyPackageConfigFGSectionDescrs   :: ( FieldGrammar c g-     , Applicative (g SourceRepoList)      , c (Identity RepoType)      , c (List NoCommaFSep FilePathNT String)      , c (NonEmpty' NoCommaFSep Token String)@@ -1836,7 +1815,6 @@  packageRepoSectionDescr   :: ( FieldGrammar c g-     , Applicative (g SourceRepoList)      , c (Identity RepoType)      , c (List NoCommaFSep FilePathNT String)      , c (NonEmpty' NoCommaFSep Token String)@@ -1846,7 +1824,7 @@   FGSectionDescr     { fgSectionName = "source-repository-package"     , fgSectionGrammar = sourceRepositoryPackageGrammar-    , fgSectionGet = map (\x -> ("", x)) . legacyPackagesRepo+    , fgSectionGet = map ("",) . legacyPackagesRepo     , fgSectionSet =         \lineno unused pkgrepo projconf -> do           unless (null unused) $@@ -2102,5 +2080,5 @@ showTokenQ :: String -> Doc showTokenQ "" = Disp.empty showTokenQ x@('-' : '-' : _) = Disp.text (show x)-showTokenQ x@('.' : []) = Disp.text (show x)+showTokenQ x@['.'] = Disp.text (show x) showTokenQ x = showToken x
+ src/Distribution/Client/ProjectConfig/Lens.hs view
@@ -0,0 +1,561 @@+module Distribution.Client.ProjectConfig.Lens where++import Distribution.Client.BuildReports.Types (ReportLevel (..))+import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (..))+import Distribution.Client.Dependency.Types (PreSolver (..))+import Distribution.Client.IndexUtils.ActiveRepos+  ( ActiveRepos+  )+import Distribution.Client.IndexUtils.IndexState (TotalIndexState)+import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared)+import qualified Distribution.Client.ProjectConfig.Types as T+import Distribution.Client.Targets (UserConstraint)+import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder)+import Distribution.Client.Types.Repo (LocalRepo, RemoteRepo)+import Distribution.Client.Types.SourceRepo (SourceRepoList)+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy)+import Distribution.Compat.Lens+import Distribution.Compat.Prelude+import Distribution.Compiler (CompilerFlavor (..))+import Distribution.Package+  ( PackageName+  )+import Distribution.PackageDescription+  ( FlagAssignment+  )+import Distribution.Simple.Compiler+  ( DebugInfoLevel (..)+  , OptimisationLevel (..)+  , PackageDBCWD+  , ProfDetailLevel+  )+import Distribution.Simple.InstallDirs+  ( InstallDirs+  , PathTemplate+  )+import Distribution.Simple.Setup+  ( DumpBuildInfo (..)+  , Flag+  , HaddockTarget (..)+  , TestShowDetails (..)+  )+import Distribution.Solver.Types.ConstraintSource (ConstraintSource)+import Distribution.Solver.Types.Settings+  ( AllowBootLibInstalls (..)+  , CountConflicts (..)+  , FineGrainedConflicts (..)+  , IndependentGoals (..)+  , MinimizeConflictSet (..)+  , OnlyConstrained (..)+  , PreferOldest (..)+  , ReorderGoals (..)+  , StrongFlags (..)+  )+import Distribution.Types.PackageVersionConstraint+  ( PackageVersionConstraint+  )+import Distribution.Types.Version (Version)+import Distribution.Utils.NubList+  ( NubList+  )+import Distribution.Verbosity++projectPackages :: Lens' ProjectConfig [String]+projectPackages f s = fmap (\x -> s{T.projectPackages = x}) (f (T.projectPackages s))+{-# INLINEABLE projectPackages #-}++projectPackagesOptional :: Lens' ProjectConfig [String]+projectPackagesOptional f s = fmap (\x -> s{T.projectPackagesOptional = x}) (f (T.projectPackagesOptional s))+{-# INLINEABLE projectPackagesOptional #-}++projectPackagesRepo :: Lens' ProjectConfig [SourceRepoList]+projectPackagesRepo f s = fmap (\x -> s{T.projectPackagesRepo = x}) (f (T.projectPackagesRepo s))+{-# INLINEABLE projectPackagesRepo #-}++projectPackagesNamed :: Lens' ProjectConfig [PackageVersionConstraint]+projectPackagesNamed f s = fmap (\x -> s{T.projectPackagesNamed = x}) (f (T.projectPackagesNamed s))+{-# INLINEABLE projectPackagesNamed #-}++projectConfigBuildOnly :: Lens' ProjectConfig ProjectConfigBuildOnly+projectConfigBuildOnly f s = fmap (\x -> s{T.projectConfigBuildOnly = x}) (f (T.projectConfigBuildOnly s))+{-# INLINEABLE projectConfigBuildOnly #-}++projectConfigShared :: Lens' ProjectConfig ProjectConfigShared+projectConfigShared f s = fmap (\x -> s{T.projectConfigShared = x}) (f (T.projectConfigShared s))+{-# INLINEABLE projectConfigShared #-}++projectConfigProvenance :: Lens' ProjectConfig (Set ProjectConfigProvenance)+projectConfigProvenance f s = fmap (\x -> s{T.projectConfigProvenance = x}) (f (T.projectConfigProvenance s))+{-# INLINEABLE projectConfigProvenance #-}++projectConfigAllPackages :: Lens' ProjectConfig PackageConfig+projectConfigAllPackages f s = fmap (\x -> s{T.projectConfigAllPackages = x}) (f (T.projectConfigAllPackages s))+{-# INLINEABLE projectConfigAllPackages #-}++projectConfigLocalPackages :: Lens' ProjectConfig PackageConfig+projectConfigLocalPackages f s = fmap (\x -> s{T.projectConfigLocalPackages = x}) (f (T.projectConfigLocalPackages s))+{-# INLINEABLE projectConfigLocalPackages #-}++projectConfigSpecificPackage :: Lens' ProjectConfig (MapMappend PackageName PackageConfig)+projectConfigSpecificPackage f s = fmap (\x -> s{T.projectConfigSpecificPackage = x}) (f (T.projectConfigSpecificPackage s))+{-# INLINEABLE projectConfigSpecificPackage #-}++projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag VerbosityFlags)+projectConfigVerbosity f s = fmap (\x -> s{T.projectConfigVerbosity = x}) (f (T.projectConfigVerbosity s))+{-# INLINEABLE projectConfigVerbosity #-}++projectConfigSummaryFile :: Lens' ProjectConfigBuildOnly (NubList PathTemplate)+projectConfigSummaryFile f s = fmap (\x -> s{T.projectConfigSummaryFile = x}) (f (T.projectConfigSummaryFile s))+{-# INLINEABLE projectConfigSummaryFile #-}++projectConfigLogFile :: Lens' ProjectConfigBuildOnly (Flag PathTemplate)+projectConfigLogFile f s = fmap (\x -> s{T.projectConfigLogFile = x}) (f (T.projectConfigLogFile s))+{-# INLINEABLE projectConfigLogFile #-}++projectConfigBuildReports :: Lens' ProjectConfigBuildOnly (Flag ReportLevel)+projectConfigBuildReports f s = fmap (\x -> s{T.projectConfigBuildReports = x}) (f (T.projectConfigBuildReports s))+{-# INLINEABLE projectConfigBuildReports #-}++projectConfigReportPlanningFailure :: Lens' ProjectConfigBuildOnly (Flag Bool)+projectConfigReportPlanningFailure f s = fmap (\x -> s{T.projectConfigReportPlanningFailure = x}) (f (T.projectConfigReportPlanningFailure s))+{-# INLINEABLE projectConfigReportPlanningFailure #-}++projectConfigSymlinkBinDir :: Lens' ProjectConfigBuildOnly (Flag FilePath)+projectConfigSymlinkBinDir f s = fmap (\x -> s{T.projectConfigSymlinkBinDir = x}) (f (T.projectConfigSymlinkBinDir s))+{-# INLINEABLE projectConfigSymlinkBinDir #-}++projectConfigNumJobs :: Lens' ProjectConfigBuildOnly (Flag (Maybe Int))+projectConfigNumJobs f s = fmap (\x -> s{T.projectConfigNumJobs = x}) (f (T.projectConfigNumJobs s))+{-# INLINEABLE projectConfigNumJobs #-}++projectConfigUseSemaphore :: Lens' ProjectConfigBuildOnly (Flag Bool)+projectConfigUseSemaphore f s = fmap (\x -> s{T.projectConfigUseSemaphore = x}) (f (T.projectConfigUseSemaphore s))+{-# INLINEABLE projectConfigUseSemaphore #-}++projectConfigKeepGoing :: Lens' ProjectConfigBuildOnly (Flag Bool)+projectConfigKeepGoing f s = fmap (\x -> s{T.projectConfigKeepGoing = x}) (f (T.projectConfigKeepGoing s))+{-# INLINEABLE projectConfigKeepGoing #-}++projectConfigOfflineMode :: Lens' ProjectConfigBuildOnly (Flag Bool)+projectConfigOfflineMode f s = fmap (\x -> s{T.projectConfigOfflineMode = x}) (f (T.projectConfigOfflineMode s))+{-# INLINEABLE projectConfigOfflineMode #-}++projectConfigKeepTempFiles :: Lens' ProjectConfigBuildOnly (Flag Bool)+projectConfigKeepTempFiles f s = fmap (\x -> s{T.projectConfigKeepTempFiles = x}) (f (T.projectConfigKeepTempFiles s))+{-# INLINEABLE projectConfigKeepTempFiles #-}++projectConfigHttpTransport :: Lens' ProjectConfigBuildOnly (Flag String)+projectConfigHttpTransport f s = fmap (\x -> s{T.projectConfigHttpTransport = x}) (f (T.projectConfigHttpTransport s))+{-# INLINEABLE projectConfigHttpTransport #-}++projectConfigIgnoreExpiry :: Lens' ProjectConfigBuildOnly (Flag Bool)+projectConfigIgnoreExpiry f s = fmap (\x -> s{T.projectConfigIgnoreExpiry = x}) (f (T.projectConfigIgnoreExpiry s))+{-# INLINEABLE projectConfigIgnoreExpiry #-}++projectConfigCacheDir :: Lens' ProjectConfigBuildOnly (Flag FilePath)+projectConfigCacheDir f s = fmap (\x -> s{T.projectConfigCacheDir = x}) (f (T.projectConfigCacheDir s))+{-# INLINEABLE projectConfigCacheDir #-}++projectConfigLogsDir :: Lens' ProjectConfigBuildOnly (Flag FilePath)+projectConfigLogsDir f s = fmap (\x -> s{T.projectConfigLogsDir = x}) (f (T.projectConfigLogsDir s))+{-# INLINEABLE projectConfigLogsDir #-}++projectConfigClientInstallFlags :: Lens' ProjectConfigBuildOnly ClientInstallFlags+projectConfigClientInstallFlags f s = fmap (\x -> s{T.projectConfigClientInstallFlags = x}) (f (T.projectConfigClientInstallFlags s))+{-# INLINEABLE projectConfigClientInstallFlags #-}++projectConfigDistDir :: Lens' ProjectConfigShared (Flag FilePath)+projectConfigDistDir f s = fmap (\x -> s{T.projectConfigDistDir = x}) (f (T.projectConfigDistDir s))+{-# INLINEABLE projectConfigDistDir #-}++projectConfigProjectDir :: Lens' ProjectConfigShared (Flag FilePath)+projectConfigProjectDir f s = fmap (\x -> s{T.projectConfigProjectDir = x}) (f (T.projectConfigProjectDir s))+{-# INLINEABLE projectConfigProjectDir #-}++projectConfigStoreDir :: Lens' ProjectConfigShared (Flag FilePath)+projectConfigStoreDir f s = fmap (\x -> s{T.projectConfigStoreDir = x}) (f (T.projectConfigStoreDir s))+{-# INLINEABLE projectConfigStoreDir #-}++projectConfigPerComponent :: Lens' ProjectConfigShared (Flag Bool)+projectConfigPerComponent f s = fmap (\x -> s{T.projectConfigPerComponent = x}) (f (T.projectConfigPerComponent s))+{-# INLINEABLE projectConfigPerComponent #-}++projectConfigIndependentGoals :: Lens' ProjectConfigShared (Flag IndependentGoals)+projectConfigIndependentGoals f s = fmap (\x -> s{T.projectConfigIndependentGoals = x}) (f (T.projectConfigIndependentGoals s))+{-# INLINEABLE projectConfigIndependentGoals #-}++projectConfigProjectFile :: Lens' ProjectConfigShared (Flag FilePath)+projectConfigProjectFile f s = fmap (\x -> s{T.projectConfigProjectFile = x}) (f (T.projectConfigProjectFile s))+{-# INLINEABLE projectConfigProjectFile #-}++projectConfigIgnoreProject :: Lens' ProjectConfigShared (Flag Bool)+projectConfigIgnoreProject f s = fmap (\x -> s{T.projectConfigIgnoreProject = x}) (f (T.projectConfigIgnoreProject s))+{-# INLINEABLE projectConfigIgnoreProject #-}++projectConfigHcFlavor :: Lens' ProjectConfigShared (Flag CompilerFlavor)+projectConfigHcFlavor f s = fmap (\x -> s{T.projectConfigHcFlavor = x}) (f (T.projectConfigHcFlavor s))+{-# INLINEABLE projectConfigHcFlavor #-}++projectConfigHcPath :: Lens' ProjectConfigShared (Flag FilePath)+projectConfigHcPath f s = fmap (\x -> s{T.projectConfigHcPath = x}) (f (T.projectConfigHcPath s))+{-# INLINEABLE projectConfigHcPath #-}++projectConfigHcPkg :: Lens' ProjectConfigShared (Flag FilePath)+projectConfigHcPkg f s = fmap (\x -> s{T.projectConfigHcPkg = x}) (f (T.projectConfigHcPkg s))+{-# INLINEABLE projectConfigHcPkg #-}++projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate)+projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s))+{-# INLINEABLE projectConfigHaddockIndex #-}++projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTemplate))+projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s))+{-# INLINEABLE projectConfigInstallDirs #-}++projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDBCWD]+projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s))+{-# INLINEABLE projectConfigPackageDBs #-}++projectConfigLocalNoIndexRepos :: Lens' ProjectConfigShared (NubList LocalRepo)+projectConfigLocalNoIndexRepos f s = fmap (\x -> s{T.projectConfigLocalNoIndexRepos = x}) (f (T.projectConfigLocalNoIndexRepos s))+{-# INLINEABLE projectConfigLocalNoIndexRepos #-}++projectConfigRemoteRepos :: Lens' ProjectConfigShared (NubList RemoteRepo)+projectConfigRemoteRepos f s = fmap (\x -> s{T.projectConfigRemoteRepos = x}) (f (T.projectConfigRemoteRepos s))+{-# INLINEABLE projectConfigRemoteRepos #-}++projectConfigActiveRepos :: Lens' ProjectConfigShared (Flag ActiveRepos)+projectConfigActiveRepos f s = fmap (\x -> s{T.projectConfigActiveRepos = x}) (f (T.projectConfigActiveRepos s))+{-# INLINEABLE projectConfigActiveRepos #-}++projectConfigIndexState :: Lens' ProjectConfigShared (Flag TotalIndexState)+projectConfigIndexState f s = fmap (\x -> s{T.projectConfigIndexState = x}) (f (T.projectConfigIndexState s))+{-# INLINEABLE projectConfigIndexState #-}++projectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)]+projectConfigConstraints f s = fmap (\x -> s{T.projectConfigConstraints = x}) (f (T.projectConfigConstraints s))+{-# INLINEABLE projectConfigConstraints #-}++projectConfigPreferences :: Lens' ProjectConfigShared [PackageVersionConstraint]+projectConfigPreferences f s = fmap (\x -> s{T.projectConfigPreferences = x}) (f (T.projectConfigPreferences s))+{-# INLINEABLE projectConfigPreferences #-}++projectConfigCabalVersion :: Lens' ProjectConfigShared (Flag Version)+projectConfigCabalVersion f s = fmap (\x -> s{T.projectConfigCabalVersion = x}) (f (T.projectConfigCabalVersion s))+{-# INLINEABLE projectConfigCabalVersion #-}++projectConfigSolver :: Lens' ProjectConfigShared (Flag PreSolver)+projectConfigSolver f s = fmap (\x -> s{T.projectConfigSolver = x}) (f (T.projectConfigSolver s))+{-# INLINEABLE projectConfigSolver #-}++projectConfigAllowOlder :: Lens' ProjectConfigShared (Maybe AllowOlder)+projectConfigAllowOlder f s = fmap (\x -> s{T.projectConfigAllowOlder = x}) (f (T.projectConfigAllowOlder s))+{-# INLINEABLE projectConfigAllowOlder #-}++projectConfigAllowNewer :: Lens' ProjectConfigShared (Maybe AllowNewer)+projectConfigAllowNewer f s = fmap (\x -> s{T.projectConfigAllowNewer = x}) (f (T.projectConfigAllowNewer s))+{-# INLINEABLE projectConfigAllowNewer #-}++projectConfigWriteGhcEnvironmentFilesPolicy :: Lens' ProjectConfigShared (Flag WriteGhcEnvironmentFilesPolicy)+projectConfigWriteGhcEnvironmentFilesPolicy f s = fmap (\x -> s{T.projectConfigWriteGhcEnvironmentFilesPolicy = x}) (f (T.projectConfigWriteGhcEnvironmentFilesPolicy s))+{-# INLINEABLE projectConfigWriteGhcEnvironmentFilesPolicy #-}++projectConfigMaxBackjumps :: Lens' ProjectConfigShared (Flag Int)+projectConfigMaxBackjumps f s = fmap (\x -> s{T.projectConfigMaxBackjumps = x}) (f (T.projectConfigMaxBackjumps s))+{-# INLINEABLE projectConfigMaxBackjumps #-}++projectConfigReorderGoals :: Lens' ProjectConfigShared (Flag ReorderGoals)+projectConfigReorderGoals f s = fmap (\x -> s{T.projectConfigReorderGoals = x}) (f (T.projectConfigReorderGoals s))+{-# INLINEABLE projectConfigReorderGoals #-}++projectConfigCountConflicts :: Lens' ProjectConfigShared (Flag CountConflicts)+projectConfigCountConflicts f s = fmap (\x -> s{T.projectConfigCountConflicts = x}) (f (T.projectConfigCountConflicts s))+{-# INLINEABLE projectConfigCountConflicts #-}++projectConfigFineGrainedConflicts :: Lens' ProjectConfigShared (Flag FineGrainedConflicts)+projectConfigFineGrainedConflicts f s = fmap (\x -> s{T.projectConfigFineGrainedConflicts = x}) (f (T.projectConfigFineGrainedConflicts s))+{-# INLINEABLE projectConfigFineGrainedConflicts #-}++projectConfigMinimizeConflictSet :: Lens' ProjectConfigShared (Flag MinimizeConflictSet)+projectConfigMinimizeConflictSet f s = fmap (\x -> s{T.projectConfigMinimizeConflictSet = x}) (f (T.projectConfigMinimizeConflictSet s))+{-# INLINEABLE projectConfigMinimizeConflictSet #-}++projectConfigStrongFlags :: Lens' ProjectConfigShared (Flag StrongFlags)+projectConfigStrongFlags f s = fmap (\x -> s{T.projectConfigStrongFlags = x}) (f (T.projectConfigStrongFlags s))+{-# INLINEABLE projectConfigStrongFlags #-}++projectConfigAllowBootLibInstalls :: Lens' ProjectConfigShared (Flag AllowBootLibInstalls)+projectConfigAllowBootLibInstalls f s = fmap (\x -> s{T.projectConfigAllowBootLibInstalls = x}) (f (T.projectConfigAllowBootLibInstalls s))+{-# INLINEABLE projectConfigAllowBootLibInstalls #-}++projectConfigOnlyConstrained :: Lens' ProjectConfigShared (Flag OnlyConstrained)+projectConfigOnlyConstrained f s = fmap (\x -> s{T.projectConfigOnlyConstrained = x}) (f (T.projectConfigOnlyConstrained s))+{-# INLINEABLE projectConfigOnlyConstrained #-}++projectConfigPreferOldest :: Lens' ProjectConfigShared (Flag PreferOldest)+projectConfigPreferOldest f s = fmap (\x -> s{T.projectConfigPreferOldest = x}) (f (T.projectConfigPreferOldest s))+{-# INLINEABLE projectConfigPreferOldest #-}++projectConfigProgPathExtra :: Lens' ProjectConfigShared (NubList FilePath)+projectConfigProgPathExtra f s = fmap (\x -> s{T.projectConfigProgPathExtra = x}) (f (T.projectConfigProgPathExtra s))+{-# INLINEABLE projectConfigProgPathExtra #-}++projectConfigMultiRepl :: Lens' ProjectConfigShared (Flag Bool)+projectConfigMultiRepl f s = fmap (\x -> s{T.projectConfigMultiRepl = x}) (f (T.projectConfigMultiRepl s))+{-# INLINEABLE projectConfigMultiRepl #-}++packageConfigProgramPaths :: Lens' PackageConfig (MapLast String FilePath)+packageConfigProgramPaths f s = fmap (\x -> s{T.packageConfigProgramPaths = x}) (f (T.packageConfigProgramPaths s))+{-# INLINEABLE packageConfigProgramPaths #-}++packageConfigProgramArgs :: Lens' PackageConfig (MapMappend String [String])+packageConfigProgramArgs f s = fmap (\x -> s{T.packageConfigProgramArgs = x}) (f (T.packageConfigProgramArgs s))+{-# INLINEABLE packageConfigProgramArgs #-}++packageConfigProgramPathExtra :: Lens' PackageConfig (NubList FilePath)+packageConfigProgramPathExtra f s = fmap (\x -> s{T.packageConfigProgramPathExtra = x}) (f (T.packageConfigProgramPathExtra s))+{-# INLINEABLE packageConfigProgramPathExtra #-}++packageConfigFlagAssignment :: Lens' PackageConfig FlagAssignment+packageConfigFlagAssignment f s = fmap (\x -> s{T.packageConfigFlagAssignment = x}) (f (T.packageConfigFlagAssignment s))+{-# INLINEABLE packageConfigFlagAssignment #-}++packageConfigVanillaLib :: Lens' PackageConfig (Flag Bool)+packageConfigVanillaLib f s = fmap (\x -> s{T.packageConfigVanillaLib = x}) (f (T.packageConfigVanillaLib s))+{-# INLINEABLE packageConfigVanillaLib #-}++packageConfigSharedLib :: Lens' PackageConfig (Flag Bool)+packageConfigSharedLib f s = fmap (\x -> s{T.packageConfigSharedLib = x}) (f (T.packageConfigSharedLib s))+{-# INLINEABLE packageConfigSharedLib #-}++packageConfigStaticLib :: Lens' PackageConfig (Flag Bool)+packageConfigStaticLib f s = fmap (\x -> s{T.packageConfigStaticLib = x}) (f (T.packageConfigStaticLib s))+{-# INLINEABLE packageConfigStaticLib #-}++packageConfigBytecodeLib :: Lens' PackageConfig (Flag Bool)+packageConfigBytecodeLib f s = fmap (\x -> s{T.packageConfigBytecodeLib = x}) (f (T.packageConfigBytecodeLib s))+{-# INLINEABLE packageConfigBytecodeLib #-}++packageConfigDynExe :: Lens' PackageConfig (Flag Bool)+packageConfigDynExe f s = fmap (\x -> s{T.packageConfigDynExe = x}) (f (T.packageConfigDynExe s))+{-# INLINEABLE packageConfigDynExe #-}++packageConfigFullyStaticExe :: Lens' PackageConfig (Flag Bool)+packageConfigFullyStaticExe f s = fmap (\x -> s{T.packageConfigFullyStaticExe = x}) (f (T.packageConfigFullyStaticExe s))+{-# INLINEABLE packageConfigFullyStaticExe #-}++packageConfigProf :: Lens' PackageConfig (Flag Bool)+packageConfigProf f s = fmap (\x -> s{T.packageConfigProf = x}) (f (T.packageConfigProf s))+{-# INLINEABLE packageConfigProf #-}++packageConfigProfLib :: Lens' PackageConfig (Flag Bool)+packageConfigProfLib f s = fmap (\x -> s{T.packageConfigProfLib = x}) (f (T.packageConfigProfLib s))+{-# INLINEABLE packageConfigProfLib #-}++packageConfigProfShared :: Lens' PackageConfig (Flag Bool)+packageConfigProfShared f s = fmap (\x -> s{T.packageConfigProfShared = x}) (f (T.packageConfigProfShared s))+{-# INLINEABLE packageConfigProfShared #-}++packageConfigProfExe :: Lens' PackageConfig (Flag Bool)+packageConfigProfExe f s = fmap (\x -> s{T.packageConfigProfExe = x}) (f (T.packageConfigProfExe s))+{-# INLINEABLE packageConfigProfExe #-}++packageConfigProfDetail :: Lens' PackageConfig (Flag ProfDetailLevel)+packageConfigProfDetail f s = fmap (\x -> s{T.packageConfigProfDetail = x}) (f (T.packageConfigProfDetail s))+{-# INLINEABLE packageConfigProfDetail #-}++packageConfigProfLibDetail :: Lens' PackageConfig (Flag ProfDetailLevel)+packageConfigProfLibDetail f s = fmap (\x -> s{T.packageConfigProfLibDetail = x}) (f (T.packageConfigProfLibDetail s))+{-# INLINEABLE packageConfigProfLibDetail #-}++packageConfigConfigureArgs :: Lens' PackageConfig [String]+packageConfigConfigureArgs f s = fmap (\x -> s{T.packageConfigConfigureArgs = x}) (f (T.packageConfigConfigureArgs s))+{-# INLINEABLE packageConfigConfigureArgs #-}++packageConfigOptimization :: Lens' PackageConfig (Flag OptimisationLevel)+packageConfigOptimization f s = fmap (\x -> s{T.packageConfigOptimization = x}) (f (T.packageConfigOptimization s))+{-# INLINEABLE packageConfigOptimization #-}++packageConfigProgPrefix :: Lens' PackageConfig (Flag PathTemplate)+packageConfigProgPrefix f s = fmap (\x -> s{T.packageConfigProgPrefix = x}) (f (T.packageConfigProgPrefix s))+{-# INLINEABLE packageConfigProgPrefix #-}++packageConfigProgSuffix :: Lens' PackageConfig (Flag PathTemplate)+packageConfigProgSuffix f s = fmap (\x -> s{T.packageConfigProgSuffix = x}) (f (T.packageConfigProgSuffix s))+{-# INLINEABLE packageConfigProgSuffix #-}++packageConfigExtraLibDirs :: Lens' PackageConfig [FilePath]+packageConfigExtraLibDirs f s = fmap (\x -> s{T.packageConfigExtraLibDirs = x}) (f (T.packageConfigExtraLibDirs s))+{-# INLINEABLE packageConfigExtraLibDirs #-}++packageConfigExtraLibDirsStatic :: Lens' PackageConfig [FilePath]+packageConfigExtraLibDirsStatic f s = fmap (\x -> s{T.packageConfigExtraLibDirsStatic = x}) (f (T.packageConfigExtraLibDirsStatic s))+{-# INLINEABLE packageConfigExtraLibDirsStatic #-}++packageConfigExtraFrameworkDirs :: Lens' PackageConfig [FilePath]+packageConfigExtraFrameworkDirs f s = fmap (\x -> s{T.packageConfigExtraFrameworkDirs = x}) (f (T.packageConfigExtraFrameworkDirs s))+{-# INLINEABLE packageConfigExtraFrameworkDirs #-}++packageConfigExtraIncludeDirs :: Lens' PackageConfig [FilePath]+packageConfigExtraIncludeDirs f s = fmap (\x -> s{T.packageConfigExtraIncludeDirs = x}) (f (T.packageConfigExtraIncludeDirs s))+{-# INLINEABLE packageConfigExtraIncludeDirs #-}++packageConfigGHCiLib :: Lens' PackageConfig (Flag Bool)+packageConfigGHCiLib f s = fmap (\x -> s{T.packageConfigGHCiLib = x}) (f (T.packageConfigGHCiLib s))+{-# INLINEABLE packageConfigGHCiLib #-}++packageConfigSplitSections :: Lens' PackageConfig (Flag Bool)+packageConfigSplitSections f s = fmap (\x -> s{T.packageConfigSplitSections = x}) (f (T.packageConfigSplitSections s))+{-# INLINEABLE packageConfigSplitSections #-}++packageConfigSplitObjs :: Lens' PackageConfig (Flag Bool)+packageConfigSplitObjs f s = fmap (\x -> s{T.packageConfigSplitObjs = x}) (f (T.packageConfigSplitObjs s))+{-# INLINEABLE packageConfigSplitObjs #-}++packageConfigStripExes :: Lens' PackageConfig (Flag Bool)+packageConfigStripExes f s = fmap (\x -> s{T.packageConfigStripExes = x}) (f (T.packageConfigStripExes s))+{-# INLINEABLE packageConfigStripExes #-}++packageConfigStripLibs :: Lens' PackageConfig (Flag Bool)+packageConfigStripLibs f s = fmap (\x -> s{T.packageConfigStripLibs = x}) (f (T.packageConfigStripLibs s))+{-# INLINEABLE packageConfigStripLibs #-}++packageConfigTests :: Lens' PackageConfig (Flag Bool)+packageConfigTests f s = fmap (\x -> s{T.packageConfigTests = x}) (f (T.packageConfigTests s))+{-# INLINEABLE packageConfigTests #-}++packageConfigBenchmarks :: Lens' PackageConfig (Flag Bool)+packageConfigBenchmarks f s = fmap (\x -> s{T.packageConfigBenchmarks = x}) (f (T.packageConfigBenchmarks s))+{-# INLINEABLE packageConfigBenchmarks #-}++packageConfigCoverage :: Lens' PackageConfig (Flag Bool)+packageConfigCoverage f s = fmap (\x -> s{T.packageConfigCoverage = x}) (f (T.packageConfigCoverage s))+{-# INLINEABLE packageConfigCoverage #-}++packageConfigRelocatable :: Lens' PackageConfig (Flag Bool)+packageConfigRelocatable f s = fmap (\x -> s{T.packageConfigRelocatable = x}) (f (T.packageConfigRelocatable s))+{-# INLINEABLE packageConfigRelocatable #-}++packageConfigDebugInfo :: Lens' PackageConfig (Flag DebugInfoLevel)+packageConfigDebugInfo f s = fmap (\x -> s{T.packageConfigDebugInfo = x}) (f (T.packageConfigDebugInfo s))+{-# INLINEABLE packageConfigDebugInfo #-}++packageConfigDumpBuildInfo :: Lens' PackageConfig (Flag DumpBuildInfo)+packageConfigDumpBuildInfo f s = fmap (\x -> s{T.packageConfigDumpBuildInfo = x}) (f (T.packageConfigDumpBuildInfo s))+{-# INLINEABLE packageConfigDumpBuildInfo #-}++packageConfigRunTests :: Lens' PackageConfig (Flag Bool)+packageConfigRunTests f s = fmap (\x -> s{T.packageConfigRunTests = x}) (f (T.packageConfigRunTests s))+{-# INLINEABLE packageConfigRunTests #-}++packageConfigDocumentation :: Lens' PackageConfig (Flag Bool)+packageConfigDocumentation f s = fmap (\x -> s{T.packageConfigDocumentation = x}) (f (T.packageConfigDocumentation s))+{-# INLINEABLE packageConfigDocumentation #-}++packageConfigHaddockHoogle :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockHoogle f s = fmap (\x -> s{T.packageConfigHaddockHoogle = x}) (f (T.packageConfigHaddockHoogle s))+{-# INLINEABLE packageConfigHaddockHoogle #-}++packageConfigHaddockHtml :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockHtml f s = fmap (\x -> s{T.packageConfigHaddockHtml = x}) (f (T.packageConfigHaddockHtml s))+{-# INLINEABLE packageConfigHaddockHtml #-}++packageConfigHaddockHtmlLocation :: Lens' PackageConfig (Flag String)+packageConfigHaddockHtmlLocation f s = fmap (\x -> s{T.packageConfigHaddockHtmlLocation = x}) (f (T.packageConfigHaddockHtmlLocation s))+{-# INLINEABLE packageConfigHaddockHtmlLocation #-}++packageConfigHaddockForeignLibs :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockForeignLibs f s = fmap (\x -> s{T.packageConfigHaddockForeignLibs = x}) (f (T.packageConfigHaddockForeignLibs s))+{-# INLINEABLE packageConfigHaddockForeignLibs #-}++packageConfigHaddockExecutables :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockExecutables f s = fmap (\x -> s{T.packageConfigHaddockExecutables = x}) (f (T.packageConfigHaddockExecutables s))+{-# INLINEABLE packageConfigHaddockExecutables #-}++packageConfigHaddockTestSuites :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockTestSuites f s = fmap (\x -> s{T.packageConfigHaddockTestSuites = x}) (f (T.packageConfigHaddockTestSuites s))+{-# INLINEABLE packageConfigHaddockTestSuites #-}++packageConfigHaddockBenchmarks :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockBenchmarks f s = fmap (\x -> s{T.packageConfigHaddockBenchmarks = x}) (f (T.packageConfigHaddockBenchmarks s))+{-# INLINEABLE packageConfigHaddockBenchmarks #-}++packageConfigHaddockInternal :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockInternal f s = fmap (\x -> s{T.packageConfigHaddockInternal = x}) (f (T.packageConfigHaddockInternal s))+{-# INLINEABLE packageConfigHaddockInternal #-}++packageConfigHaddockCss :: Lens' PackageConfig (Flag FilePath)+packageConfigHaddockCss f s = fmap (\x -> s{T.packageConfigHaddockCss = x}) (f (T.packageConfigHaddockCss s))+{-# INLINEABLE packageConfigHaddockCss #-}++packageConfigHaddockLinkedSource :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockLinkedSource f s = fmap (\x -> s{T.packageConfigHaddockLinkedSource = x}) (f (T.packageConfigHaddockLinkedSource s))+{-# INLINEABLE packageConfigHaddockLinkedSource #-}++packageConfigHaddockQuickJump :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockQuickJump f s = fmap (\x -> s{T.packageConfigHaddockQuickJump = x}) (f (T.packageConfigHaddockQuickJump s))+{-# INLINEABLE packageConfigHaddockQuickJump #-}++packageConfigHaddockHscolourCss :: Lens' PackageConfig (Flag FilePath)+packageConfigHaddockHscolourCss f s = fmap (\x -> s{T.packageConfigHaddockHscolourCss = x}) (f (T.packageConfigHaddockHscolourCss s))+{-# INLINEABLE packageConfigHaddockHscolourCss #-}++packageConfigHaddockContents :: Lens' PackageConfig (Flag PathTemplate)+packageConfigHaddockContents f s = fmap (\x -> s{T.packageConfigHaddockContents = x}) (f (T.packageConfigHaddockContents s))+{-# INLINEABLE packageConfigHaddockContents #-}++packageConfigHaddockIndex :: Lens' PackageConfig (Flag PathTemplate)+packageConfigHaddockIndex f s = fmap (\x -> s{T.packageConfigHaddockIndex = x}) (f (T.packageConfigHaddockIndex s))+{-# INLINEABLE packageConfigHaddockIndex #-}++packageConfigHaddockBaseUrl :: Lens' PackageConfig (Flag String)+packageConfigHaddockBaseUrl f s = fmap (\x -> s{T.packageConfigHaddockBaseUrl = x}) (f (T.packageConfigHaddockBaseUrl s))+{-# INLINEABLE packageConfigHaddockBaseUrl #-}++packageConfigHaddockResourcesDir :: Lens' PackageConfig (Flag String)+packageConfigHaddockResourcesDir f s = fmap (\x -> s{T.packageConfigHaddockResourcesDir = x}) (f (T.packageConfigHaddockResourcesDir s))+{-# INLINEABLE packageConfigHaddockResourcesDir #-}++packageConfigHaddockOutputDir :: Lens' PackageConfig (Flag FilePath)+packageConfigHaddockOutputDir f s = fmap (\x -> s{T.packageConfigHaddockOutputDir = x}) (f (T.packageConfigHaddockOutputDir s))+{-# INLINEABLE packageConfigHaddockOutputDir #-}++packageConfigHaddockUseUnicode :: Lens' PackageConfig (Flag Bool)+packageConfigHaddockUseUnicode f s = fmap (\x -> s{T.packageConfigHaddockUseUnicode = x}) (f (T.packageConfigHaddockUseUnicode s))+{-# INLINEABLE packageConfigHaddockUseUnicode #-}++packageConfigHaddockForHackage :: Lens' PackageConfig (Flag HaddockTarget)+packageConfigHaddockForHackage f s = fmap (\x -> s{T.packageConfigHaddockForHackage = x}) (f (T.packageConfigHaddockForHackage s))+{-# INLINEABLE packageConfigHaddockForHackage #-}++packageConfigTestHumanLog :: Lens' PackageConfig (Flag PathTemplate)+packageConfigTestHumanLog f s = fmap (\x -> s{T.packageConfigTestHumanLog = x}) (f (T.packageConfigTestHumanLog s))+{-# INLINEABLE packageConfigTestHumanLog #-}++packageConfigTestMachineLog :: Lens' PackageConfig (Flag PathTemplate)+packageConfigTestMachineLog f s = fmap (\x -> s{T.packageConfigTestMachineLog = x}) (f (T.packageConfigTestMachineLog s))+{-# INLINEABLE packageConfigTestMachineLog #-}++packageConfigTestShowDetails :: Lens' PackageConfig (Flag TestShowDetails)+packageConfigTestShowDetails f s = fmap (\x -> s{T.packageConfigTestShowDetails = x}) (f (T.packageConfigTestShowDetails s))+{-# INLINEABLE packageConfigTestShowDetails #-}++packageConfigTestKeepTix :: Lens' PackageConfig (Flag Bool)+packageConfigTestKeepTix f s = fmap (\x -> s{T.packageConfigTestKeepTix = x}) (f (T.packageConfigTestKeepTix s))+{-# INLINEABLE packageConfigTestKeepTix #-}++packageConfigTestWrapper :: Lens' PackageConfig (Flag FilePath)+packageConfigTestWrapper f s = fmap (\x -> s{T.packageConfigTestWrapper = x}) (f (T.packageConfigTestWrapper s))+{-# INLINEABLE packageConfigTestWrapper #-}++packageConfigTestFailWhenNoTestSuites :: Lens' PackageConfig (Flag Bool)+packageConfigTestFailWhenNoTestSuites f s = fmap (\x -> s{T.packageConfigTestFailWhenNoTestSuites = x}) (f (T.packageConfigTestFailWhenNoTestSuites s))+{-# INLINEABLE packageConfigTestFailWhenNoTestSuites #-}++packageConfigTestTestOptions :: Lens' PackageConfig [PathTemplate]+packageConfigTestTestOptions f s = fmap (\x -> s{T.packageConfigTestTestOptions = x}) (f (T.packageConfigTestTestOptions s))+{-# INLINEABLE packageConfigTestTestOptions #-}++packageConfigBenchmarkOptions :: Lens' PackageConfig [PathTemplate]+packageConfigBenchmarkOptions f s = fmap (\x -> s{T.packageConfigBenchmarkOptions = x}) (f (T.packageConfigBenchmarkOptions s))+{-# INLINEABLE packageConfigBenchmarkOptions #-}
+ src/Distribution/Client/ProjectConfig/Parsec.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Parsing project configuration.+module Distribution.Client.ProjectConfig.Parsec+  ( -- * Package configuration+    parseProject+  , ProjectConfig (..)++    -- ** Parsing+  , ParseResult+  , runParseResult+  ) where++import Distribution.CabalSpecVersion+import Distribution.Client.HttpUtils+import Distribution.Client.ProjectConfig.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar)+import Distribution.Client.ProjectConfig.Import (ProjectConfigSkeleton, cyclicalImportMsg, fetchImport, untrimmedUriImportMsg)+import qualified Distribution.Client.ProjectConfig.Lens as L+import Distribution.Client.ProjectConfig.Types+import Distribution.Client.Types.Repo hiding (repoName)+import Distribution.Client.Types.RepoName (RepoName (..))+import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar)+import Distribution.Client.Utils.Parsec+import Distribution.Compat.Lens+import Distribution.Compat.Prelude+import Distribution.FieldGrammar+import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn)+import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields')+import Distribution.Fields.ConfVar (parseConditionConfVar)+import Distribution.Fields.Field (fieldLinesToString, sectionArgAnn)+import Distribution.Fields.LexerMonad (toPWarnings)+import Distribution.Fields.ParseResult+import Distribution.Parsec (ParsecParser, eitherParsec, parsec, parsecFilePath, runParsecParser)+import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)+import Distribution.Parsec.Position (Position (..), incPos, zeroPos)+import Distribution.Parsec.Warning (PWarnType (..))+import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram)+import Distribution.Simple.Program.Types (programName)+import Distribution.Simple.Setup+import Distribution.Simple.Utils (debug, noticeDoc)+import Distribution.Solver.Types.ProjectConfigPath+import Distribution.System (buildOS)+import Distribution.Types.CondTree (CondBranch (..), CondTree (..))+import Distribution.Types.ConfVar (ConfVar (..))+import Distribution.Types.PackageName (PackageName)+import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8)+import Distribution.Utils.NubList (toNubList)+import Distribution.Verbosity++import Control.Monad.State.Strict (StateT, execStateT, lift)+import qualified Data.ByteString as BS+import Data.Functor ((<&>))+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Distribution.Client.Errors.Parser (ProjectFileSource (..))+import qualified Distribution.Compat.CharParsing as P+import Network.URI (URI, uriFragment, uriPath, uriScheme)+import System.Directory (makeAbsolute)+import System.FilePath (splitFileName)+import qualified Text.Parsec+import Text.PrettyPrint (render)+import qualified Text.PrettyPrint as Disp++singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton+singletonProjectConfigSkeleton x = CondNode (mempty, x) mempty++readPreprocessFields :: BS.ByteString -> ParseResult src [Field Position]+readPreprocessFields bs = do+  case readFields' bs' of+    Right (fs, lexWarnings) -> do+      parseWarnings (toPWarnings lexWarnings)+      for_ invalidUtf8 $ \pos ->+        parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos+      return fs+    Left perr -> parseFatalFailure pos (show perr)+      where+        ppos = Text.Parsec.errorPos perr+        pos = Position (Text.Parsec.sourceLine ppos) (Text.Parsec.sourceColumn ppos)+  where+    invalidUtf8 = validateUTF8 bs+    bs' = case invalidUtf8 of+      Nothing -> bs+      Just _ -> toUTF8BS (fromUTF8BS bs)++-- | Parses a project from its root config file, typically cabal.project.+parseProject+  :: FilePath+  -- ^ The root of the project configuration, typically cabal.project+  -> FilePath+  -> HttpTransport+  -> Verbosity+  -> ProjectConfigToParse+  -- ^ The contents of the file to parse+  -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)+parseProject rootPath cacheDir httpTransport verbosity configToParse = do+  let (dir, projectFileName) = splitFileName rootPath+  projectDir <- makeAbsolute dir+  projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])+  parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse++parseProjectSkeleton+  :: FilePath+  -> HttpTransport+  -> Verbosity+  -> FilePath+  -- ^ The directory of the project configuration, typically the directory of cabal.project+  -> ProjectConfigPath+  -- ^ The path of the file being parsed, either the root or an import+  -> ProjectConfigToParse+  -- ^ The contents of the file to parse+  -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)+parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = do+  normSource <- canonicalizeConfigPath projectDir source+  res <- (sanityWalkPCS False =<<) <$> liftParseResult (go []) (readPreprocessFields bs)+  pure $ withSource (ProjectFileSource (normSource, bs)) res+  where+    go :: [Field Position] -> [Field Position] -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)+    go acc (x : xs) = case x of+      (Field (Name pos name) importLines) | name == "import" -> do+        liftParseResult+          ( \importLoc -> do+              let importLocPath = importLoc `consProjectConfigPath` source++              -- Once we canonicalize the import path, we can check for cyclical imports+              normSource <- canonicalizeConfigPath projectDir source+              normLocPath <- canonicalizeConfigPath projectDir importLocPath+              debug verbosity $ "\nimport path, normalized\n=======================\n" ++ render (docProjectConfigPath normLocPath)++              if isCyclicConfigPath normLocPath+                then pure $ parseFatalFailure pos (render $ cyclicalImportMsg normLocPath)+                else do+                  when+                    (isUntrimmedUriConfigPath importLocPath)+                    (noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)+                  let parser = parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath+                  (mbUri, importParseResult) <- fetchImport parser cacheDir httpTransport verbosity projectDir normLocPath+                  rest <- go [] xs+                  let fs = (\z -> CondNode ([(mbUri, normLocPath)], z) mempty) <$> fieldsToConfig normSource (reverse acc)+                  pure . fmap mconcat . sequence $ [fs, importParseResult, rest]+          )+          (parseImport pos importLines)+      (Section (Name pos "if") args xs') -> do+        subpcs <- go [] xs'+        let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig source (reverse acc)+        (elseClauses, rest) <- parseElseClauses xs+        let condNode =+              (\c pcs e -> CondNode mempty [CondBranch c pcs e])+                <$> parseConditionConfVar (startOfSection (incPos 2 pos) args) args+                <*> subpcs+                <*> elseClauses+        pure . fmap mconcat . sequence $ [fs, condNode, rest]+      _ -> go (x : acc) xs+    go acc [] = do+      normSource <- canonicalizeConfigPath projectDir source+      pure . fmap singletonProjectConfigSkeleton . fieldsToConfig normSource $ reverse acc++    parseElseClauses :: [Field Position] -> IO (ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton), ParseResult ProjectFileSource ProjectConfigSkeleton)+    parseElseClauses x = case x of+      (Section (Name _pos "else") _args xs' : xs) -> do+        subpcs <- go [] xs'+        rest <- go [] xs+        pure (Just <$> subpcs, rest)+      (Section (Name pos "elif") args xs' : xs) -> do+        subpcs <- go [] xs'+        (elseClauses, rest) <- parseElseClauses xs+        let condNode =+              (\c pcs e -> CondNode mempty [CondBranch c pcs e])+                <$> parseConditionConfVar (startOfSection (incPos 4 pos) args) args+                <*> subpcs+                <*> elseClauses+        pure (Just <$> condNode, rest)+      _ -> (pure Nothing,) <$> go [] x++    parseImport :: Position -> [FieldLine Position] -> ParseResult ProjectFileSource FilePath+    parseImport pos lines' = runFieldParser pos (P.many P.anyChar) cabalSpec lines'++    -- We want a normalized path for @fieldsToConfig@. This eventually surfaces+    -- in solver rejection messages and build messages "this build was affected+    -- by the following (project) config files" so we want all paths shown there+    -- to be relative to the directory of the project, not relative to the file+    -- they were imported from.+    fieldsToConfig :: ProjectConfigPath -> [Field Position] -> ParseResult ProjectFileSource ProjectConfig+    fieldsToConfig sourceConfigPath xs = do+      let (fs, sectionGroups) = partitionFields xs+          sections = concat sectionGroups+      config <- parseFieldGrammarCheckingStanzas cabalSpec fs (projectConfigFieldGrammar sourceConfigPath (knownProgramNames programDb)) stanzas+      config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config)+      return config'+    modifiesCompiler :: ProjectConfig -> Bool+    modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg+      where+        isSet f = f (projectConfigShared pc) /= NoFlag++    sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectFileSource ProjectConfigSkeleton+    sanityWalkPCS underConditional t@(CondNode (_c, d) comps)+      | underConditional && modifiesCompiler d = parseFatalFailure zeroPos "Cannot set compiler in a conditional clause of a cabal project file"+      | otherwise = mapM_ sanityWalkBranch comps >> pure t++    sanityWalkBranch :: CondBranch ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig) -> ParseResult ProjectFileSource ()+    sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()++    programDb = defaultProgramDb++startOfSection :: Position -> [SectionArg Position] -> Position+-- The case where we have no args is the start of the section+startOfSection defaultPos [] = defaultPos+-- Otherwise the start of the section is the position of the first argument.+startOfSection _ (cond : _) = sectionArgAnn cond++knownProgramNames :: ProgramDb -> [String]+knownProgramNames programDb = programName . fst <$> knownPrograms programDb++-- | Monad in which sections are parsed+type SectionParser src = StateT SectionS (ParseResult src)++-- | State of 'SectionParser'+newtype SectionS = SectionS+  { _stateConfig :: ProjectConfig+  }++stateConfig :: Lens' SectionS ProjectConfig+stateConfig f (SectionS cfg) = SectionS <$> f cfg+{-# INLINEABLE stateConfig #-}++goSections :: ProgramDb -> [Section Position] -> SectionParser src ()+goSections programDb = traverse_ (parseSection programDb)++parseSection :: ProgramDb -> Section Position -> SectionParser src ()+parseSection programDb (MkSection (Name pos name) args secFields)+  | name == "source-repository-package" = do+      verifyNullSubsections+      verifyNullSectionArgs+      srp <- lift $ parseFieldGrammar cabalSpec fields sourceRepositoryPackageGrammar+      stateConfig . L.projectPackagesRepo %= (<> [srp])+  | name == "program-options" = do+      verifyNullSubsections+      verifyNullSectionArgs+      opts' <- lift $ parseProgramArgs programDb fields+      stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>)+  | name == "program-locations" = do+      verifyNullSubsections+      verifyNullSectionArgs+      paths' <- lift $ parseProgramPaths programDb fields+      stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramPaths %= (paths' <>)+  | name == "repository" = do+      verifyNullSubsections+      mRepoName <- lift $ parseRepoName pos args+      case mRepoName of+        Just repoName -> do+          remoteRepo <- lift $ parseFieldGrammar cabalSpec fields (remoteRepoGrammar repoName)+          remoteOrLocalRepo <- lift $ postProcessRemoteRepo pos remoteRepo+          case remoteOrLocalRepo of+            Left local -> stateConfig . L.projectConfigShared . L.projectConfigLocalNoIndexRepos %= (<> toNubList [local])+            Right remote -> stateConfig . L.projectConfigShared . L.projectConfigRemoteRepos %= (<> toNubList [remote])+        Nothing -> lift $ parseFailure pos "a 'repository' section requires the repository name as an argument"+  | name == "package" = do+      verifyNullSubsections+      package <- lift $ parsePackageName pos args+      case package of+        Just AllPackages -> do+          packageCfg' <- parsePackageConfig+          stateConfig . L.projectConfigAllPackages %= (packageCfg' <>)+        Just (SpecificPackage packageName) -> do+          packageCfg <- parsePackageConfig+          stateConfig . L.projectConfigSpecificPackage %= (<> MapMappend (Map.singleton packageName packageCfg))+        Nothing -> do+          lift $ parseWarning pos PWTUnknownSection "target package name or * required"+          return ()+  | otherwise = do+      warnInvalidSubsection pos name+  where+    (fields, sections) = partitionFields secFields+    warnInvalidSubsection pos' name' = lift $ parseWarning pos' PWTInvalidSubsection $ "Invalid subsection " ++ show name'+    programNames = knownProgramNames programDb+    verifyNullSubsections = unless (null sections) (warnInvalidSubsection pos name)+    verifyNullSectionArgs = unless (null args) (lift $ parseFailure pos $ "The section '" <> show name <> "' takes no arguments")+    parsePackageConfig = do+      packageCfg <- lift $ parseFieldGrammar cabalSpec fields (packageConfigFieldGrammar programNames)+      args' <- lift $ parseProgramArgs programDb fields+      paths <- lift $ parseProgramPaths programDb fields+      return packageCfg{packageConfigProgramPaths = paths, packageConfigProgramArgs = args'}++stanzas :: Set BS.ByteString+stanzas = Set.fromList ["source-repository-package", "program-options", "program-locations", "repository", "package"]++-- | Currently a duplicate of 'Distribution.Client.Config.postProcessRepo' but migrated to Parsec ParseResult.+postProcessRemoteRepo :: Position -> RemoteRepo -> ParseResult src (Either LocalRepo RemoteRepo)+postProcessRemoteRepo pos repo = case uriScheme (remoteRepoURI repo) of+  -- TODO: check that there are no authority, query or fragment+  -- Note: the trailing colon is important+  "file+noindex:" -> do+    let uri = normaliseFileNoIndexURI buildOS $ remoteRepoURI repo+    return $ Left $ LocalRepo (remoteRepoName repo) (uriPath uri) (uriFragment uri == "#shared-cache")+  _ -> do+    when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $+      warning $+        "'key-threshold' for repository "+          ++ show (remoteRepoName repo)+          ++ " higher than number of keys"++    when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $+      warning $+        "'root-keys' for repository "+          ++ show (remoteRepoName repo)+          ++ " non-empty, but 'secure' not set to True."++    return $ Right repo+    where+      warning msg = parseWarning pos PWTOther msg++parseRepoName :: Position -> [SectionArg Position] -> ParseResult src (Maybe RepoName)+parseRepoName pos args = case args of+  [SecArgName _ secName] -> parseName secName+  [SecArgStr _ secName] -> parseName secName+  [SecArgOther _ secName] -> parseName secName+  _ -> return Nothing+  where+    parseName :: BS.ByteString -> ParseResult src (Maybe RepoName)+    parseName str =+      let repoNameStr = fromUTF8BS str+       in case eitherParsec repoNameStr of+            Left _ -> do+              parseFailure pos ("Invalid repository name" ++ repoNameStr)+              return Nothing+            Right name -> return $ Just name++data PackageConfigTarget = AllPackages | SpecificPackage !PackageName++parsePackageName :: Position -> [SectionArg Position] -> ParseResult src (Maybe PackageConfigTarget)+parsePackageName pos args = case args of+  [SecArgName _ secName] -> parseName secName+  [SecArgStr _ secName] -> parseName secName+  [SecArgOther _ secName] -> parseName secName+  _ -> return Nothing+  where+    parseName secName = case runParsecParser parser "<parsePackageName>" (fieldLineStreamFromBS secName) of+      Left _ -> do+        parseFailure pos ("Invalid package name" ++ fromUTF8BS secName)+        return Nothing+      Right cfgTarget -> return $ pure cfgTarget+    parser :: ParsecParser PackageConfigTarget+    parser =+      P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec]++-- | Parse fields of a program-options stanza.+parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult src (MapMappend String [String])+parseProgramArgs programDb fields = foldM parseField mempty (filter hasOptionsSuffix $ Map.toList fields)+  where+    parseField programArgs (fieldName, fieldLines) = do+      case readProgramName "-options" programDb fieldName of+        Nothing -> warnUnknownFields fieldName fieldLines >> return programArgs+        Just program -> do+          args <- parseProgramArgsField $ reverse fieldLines+          return $ programArgs <> MapMappend (Map.singleton program args)+    hasOptionsSuffix (fieldName, _) = BS.isSuffixOf "-options" fieldName++-- | Parse fields of a program-locations stanza.+parseProgramPaths :: ProgramDb -> Fields Position -> ParseResult src (MapLast String FilePath)+parseProgramPaths programDb fields = foldM parseField mempty (filter hasLocationSuffix $ Map.toList fields)+  where+    parseField paths (fieldName, fieldLines) = do+      case readProgramName "-location" programDb fieldName of+        Nothing -> warnUnknownFields fieldName fieldLines >> return paths+        Just program -> do+          case fieldLines of+            (MkNamelessField pos lines') : _ -> do+              fp <- runFieldParser pos parsecFilePath cabalSpec lines'+              return $ paths <> MapLast (Map.singleton program fp)+            [] -> return mempty+    hasLocationSuffix (fieldName, _) = BS.isSuffixOf "-location" fieldName++-- | Parse all arguments to a single program in program-options stanza.+-- By processing '[NamelessField Position]', we support multiple occurrences of the field, concatenating the arguments.+parseProgramArgsField :: [NamelessField Position] -> ParseResult src [String]+parseProgramArgsField fieldLines =+  concat <$> mapM (\(MkNamelessField _ lines') -> parseProgramArgsFieldLines lines') fieldLines++-- | Parse all fieldLines of a single field occurrence in a program-options stanza.+parseProgramArgsFieldLines :: [FieldLine Position] -> ParseResult src [String]+parseProgramArgsFieldLines lines' = return $ splitArgs strLines+  where+    strLines = fieldLinesToString lines'++type FieldSuffix = String++-- | Extract the program name of a <progname> field, allow it to have a suffix such as '-options' and check whether the 'ProgramDB' contains it.+readProgramName :: FieldSuffix -> ProgramDb -> FieldName -> Maybe String+readProgramName suffix programDb fieldName =+  (parseProgramName suffix fieldName >>= (`lookupKnownProgram` programDb)) <&> programName++parseProgramName :: FieldSuffix -> FieldName -> Maybe String+parseProgramName suffix fieldName = case runParsecParser parser "<parseProgramName>" fieldNameStream of+  Left _ -> Nothing+  Right str -> Just str+  where+    parser = P.manyTill P.anyChar (P.try (P.string suffix) <* P.eof)+    fieldNameStream = fieldLineStreamFromBS fieldName++-- | Issue a 'PWTUnknownField' warning at all occurrences of a field.+warnUnknownFields :: FieldName -> [NamelessField Position] -> ParseResult src ()+warnUnknownFields fieldName fieldLines = for_ fieldLines (\field -> parseWarning (pos field) PWTUnknownField message)+  where+    message = "Unknown field: " ++ show fieldName+    pos = namelessFieldAnn++cabalSpec :: CabalSpecVersion+cabalSpec = cabalSpecLatest
src/Distribution/Client/ProjectConfig/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -10,6 +11,8 @@   , ProjectConfigShared (..)   , ProjectConfigProvenance (..)   , PackageConfig (..)+  , ProjectFileParser (..)+  , defaultProjectFileParser      -- * Resolving configuration   , SolverSettings (..)@@ -97,6 +100,7 @@ import qualified Data.Map as Map import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath) import Distribution.Types.ParStrat+import Distribution.Verbosity (VerbosityFlags)  ------------------------------- -- Project config types@@ -158,7 +162,7 @@ -- does not need to be tracked for changes since it does not affect the -- outcome. data ProjectConfigBuildOnly = ProjectConfigBuildOnly-  { projectConfigVerbosity :: Flag Verbosity+  { projectConfigVerbosity :: Flag VerbosityFlags   , projectConfigDryRun :: Flag Bool   , projectConfigOnlyDeps :: Flag Bool   , projectConfigOnlyDownload :: Flag Bool@@ -168,6 +172,7 @@   , projectConfigReportPlanningFailure :: Flag Bool   , projectConfigSymlinkBinDir :: Flag FilePath   , projectConfigNumJobs :: Flag (Maybe Int)+  -- ^ Use 'Just n' for number of jobs, 'Nothing' for number of jobs equal to the number of CPUs and 'NoFlag' if flag is not given.   , projectConfigUseSemaphore :: Flag Bool   , projectConfigKeepGoing :: Flag Bool   , projectConfigOfflineMode :: Flag Bool@@ -187,6 +192,7 @@   , projectConfigConfigFile :: Flag FilePath   , projectConfigProjectDir :: Flag FilePath   , projectConfigProjectFile :: Flag FilePath+  , projectConfigProjectFileParser :: Flag ProjectFileParser   , projectConfigIgnoreProject :: Flag Bool   , projectConfigHcFlavor :: Flag CompilerFlavor   , projectConfigHcPath :: Flag FilePath@@ -237,6 +243,22 @@   }   deriving (Eq, Show, Generic) +data ProjectFileParser+  = LegacyParser+  | ParsecParser+  | FallbackParser+  | CompareParser+  deriving (Eq, Show, Generic)++instance NFData ProjectFileParser++defaultProjectFileParser :: ProjectFileParser+#ifdef LEGACY_COMPARISON+defaultProjectFileParser = CompareParser+#else+defaultProjectFileParser = FallbackParser+#endif+ -- | Specifies the provenance of project configuration, whether defaults were -- used or if the configuration was read from an explicit file path. data ProjectConfigProvenance@@ -260,6 +282,7 @@   , packageConfigVanillaLib :: Flag Bool   , packageConfigSharedLib :: Flag Bool   , packageConfigStaticLib :: Flag Bool+  , packageConfigBytecodeLib :: Flag Bool   , packageConfigDynExe :: Flag Bool   , packageConfigFullyStaticExe :: Flag Bool   , packageConfigProf :: Flag Bool -- TODO: [code cleanup] sort out@@ -327,13 +350,28 @@ instance Binary ProjectConfigShared instance Binary ProjectConfigProvenance instance Binary PackageConfig+instance Binary ProjectFileParser  instance Structured ProjectConfig instance Structured ProjectConfigBuildOnly instance Structured ProjectConfigShared instance Structured ProjectConfigProvenance instance Structured PackageConfig+instance Structured ProjectFileParser +instance NFData ProjectConfigToParse where+  rnf (ProjectConfigToParse bs) = rnf bs++instance NFData ProjectConfig+instance NFData ProjectConfigBuildOnly+instance NFData ProjectConfigShared++instance NFData ProjectConfigProvenance where+  rnf Implicit = ()+  rnf (Explicit path) = rnf path++instance NFData PackageConfig+ -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes -- the last value rather than the first value for overlapping keys. newtype MapLast k v = MapLast {getMapLast :: Map k v}@@ -341,6 +379,8 @@  instance (Structured k, Structured v) => Structured (MapLast k v) +instance (NFData k, NFData v) => NFData (MapLast k v)+ instance Ord k => Monoid (MapLast k v) where   mempty = MapLast Map.empty   mappend = (<>)@@ -357,6 +397,8 @@  instance (Structured k, Structured v) => Structured (MapMappend k v) +instance (NFData k, NFData v) => NFData (MapMappend k v)+ instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where   mempty = MapMappend Map.empty   mappend = (<>)@@ -441,6 +483,7 @@   deriving (Eq, Show, Generic)  instance Binary SolverSettings+instance NFData SolverSettings instance Structured SolverSettings  -- | Resolved configuration for things that affect how we build and not the@@ -480,3 +523,6 @@   , buildSettingProgPathExtra :: [FilePath]   , buildSettingHaddockOpen :: Bool   }+  deriving (Generic)++instance NFData BuildTimeSettings
src/Distribution/Client/ProjectFlags.hs view
@@ -10,9 +10,10 @@   ) where  import Distribution.Client.Compat.Prelude+import Distribution.Client.ProjectConfig.Types (ProjectFileParser (..), defaultProjectFileParser) import Prelude () -import Distribution.ReadE (succeedReadE)+import Distribution.ReadE (ReadE (..), succeedReadE) import Distribution.Simple.Command   ( MkOptDescr   , OptionField (optionName)@@ -47,6 +48,8 @@   , flagIgnoreProject :: Flag Bool   -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)   -- The exact interpretation might be slightly different per command.+  , flagProjectFileParser :: Flag ProjectFileParser+  -- ^ The parser to use for the project file.   }   deriving (Show, Generic) @@ -56,7 +59,7 @@     { flagProjectDir = mempty     , flagProjectFile = mempty     , flagIgnoreProject = toFlag False-    -- Should we use 'Last' here?+    , flagProjectFileParser = mempty     }  projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]@@ -88,7 +91,31 @@             }       )       (yesNoOpt showOrParseArgs)+  , option+      []+      ["project-file-parser"]+      "Set the parser to use for the project file"+      flagProjectFileParser+      (\pf flags -> flags{flagProjectFileParser = pf})+      (reqArg "PARSER" (fmap Flag $ ReadE parseProjectFileParser) projectFileParserPrinter)   ]++parseProjectFileParser :: String -> Either String ProjectFileParser+parseProjectFileParser "legacy" = pure LegacyParser+parseProjectFileParser "fallback" = pure FallbackParser+parseProjectFileParser "default" = pure defaultProjectFileParser+parseProjectFileParser "parsec" = pure ParsecParser+parseProjectFileParser "compare" = pure CompareParser+parseProjectFileParser _ = Left "Invalid project file parser"++projectFileParserPrinter :: Flag ProjectFileParser -> [String]+projectFileParserPrinter (Flag parser) =+  case parser of+    LegacyParser -> ["legacy"]+    FallbackParser -> ["fallback"]+    ParsecParser -> ["parsec"]+    CompareParser -> ["compare"]+projectFileParserPrinter NoFlag = []  -- | As almost all commands use 'ProjectFlags' but not all can honour -- "ignore-project" flag, provide this utility to remove the flag
src/Distribution/Client/ProjectOrchestration.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -105,7 +106,7 @@   ) where  import Distribution.Client.Compat.Prelude-import Distribution.Compat.Directory+import System.Directory   ( makeAbsolute   ) import Prelude ()@@ -296,10 +297,7 @@         } = projectConfigShared projectConfig        mlogsDir = Setup.flagToMaybe projectConfigLogsDir-  mstoreDir <--    sequenceA $-      makeAbsolute-        <$> Setup.flagToMaybe projectConfigStoreDir+  mstoreDir <- traverse makeAbsolute (Setup.flagToMaybe projectConfigStoreDir)    cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir @@ -310,8 +308,10 @@           projectConfig    -- https://github.com/haskell/cabal/issues/6013+  -- https://github.com/haskell/cabal/issues/7401+  let projPath = distProjectFile distDirLayout ProjectFileKeyMain   when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $-    warn verbosity "There are no packages or optional-packages in the project"+    dieWithException verbosity (ProjectConfigNoPackages projPath)    return     ProjectBaseContext@@ -471,7 +471,7 @@     where       previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes       previousBuildOutcomes =-        Map.mapMaybe $ \status -> case status of+        Map.mapMaybe $ \case           BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)           -- TODO: [nice to have] record build failures persistently           _ -> Nothing@@ -582,7 +582,7 @@  -- | Resolve targets from a solver result. ----- This is a convenience wrapper around 'resolveTargetsFromSolver' that takes an+-- This is a convenience wrapper around 'resolveTargets' that takes an -- 'ElaboratedInstallPlan' directly, rather than requiring the caller to -- construct the 'AvailableTargetIndexes' first. resolveTargetsFromSolver@@ -598,7 +598,7 @@        -> Either (TargetProblem err) k      )   -> ElaboratedInstallPlan-  -> Maybe (SourcePackageDb)+  -> Maybe SourcePackageDb   -> [TargetSelector]   -> Either [TargetProblem err] TargetsMap resolveTargetsFromSolver selectPackageTargets selectComponentTarget installPlan sourceDb targetSelectors =@@ -682,7 +682,7 @@        -> Either (TargetProblem err) k      )   -> AvailableTargetIndexes u-  -> Maybe (SourcePackageDb)+  -> Maybe SourcePackageDb   -> [TargetSelector]   -> Either [TargetProblem err] (TargetsMapX u) resolveTargets@@ -783,7 +783,7 @@         -> [(b, ComponentName)]         -> [(b, ComponentTarget)]       componentTargets subtarget =-        map (fmap (\cname -> ComponentTarget cname subtarget))+        map (fmap (`ComponentTarget` subtarget))        selectComponentTargets         :: SubComponentTarget@@ -856,7 +856,7 @@     availableTargetsByPackageNameAndComponentName =       Map.mapKeysWith         (++)-        (\(pkgid, cname) -> (packageName pkgid, cname))+        (first packageName)         availableTargetsByPackageIdAndComponentName      availableTargetsByPackageNameAndUnqualComponentName@@ -955,7 +955,7 @@     availableTargetsByPackageNameAndComponentName =       Map.mapKeysWith         (++)-        (\(pkgid, cname) -> (packageName pkgid, cname))+        (first packageName)         availableTargetsByPackageIdAndComponentName      availableTargetsByPackageNameAndUnqualComponentName@@ -1018,7 +1018,7 @@   (fmap . map) forgetTargetDetail . unzip . zipBuildableTargetsWith p  forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()-forgetTargetDetail = fmap (const ())+forgetTargetDetail = void  forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] forgetTargetsDetail = map forgetTargetDetail@@ -1120,11 +1120,11 @@       pkgs = InstallPlan.executionOrder elaboratedPlan        ifVerbose s-        | verbosity >= verbose = s+        | verbosityLevel verbosity >= Verbose = s         | otherwise = ""        ifNormal s-        | verbosity >= verbose = ""+        | verbosityLevel verbosity >= Verbose = ""         | otherwise = s        wouldWill@@ -1134,9 +1134,10 @@       showPkgAndReason :: ElaboratedReadyPackage -> String       showPkgAndReason (ReadyPackage elab) =         unwords $-          filter (not . null) $+          filter+            (not . null)             [ " -"-            , if verbosity >= deafening+            , if verbosityLevel verbosity >= Deafening                 then prettyShow (installedUnitId elab)                 else prettyShow (packageId elab)             , case elabBuildStyle elab of@@ -1189,9 +1190,10 @@                 verbosity                 Nothing -- omit working directory                 (makeSymbolicPath "$builddir")+                (setupHsConfigureArgs elab)                 buildSettingKeepTempFiles             fullConfigureFlags =-              runIdentity $+              runIdentity                 ( setupHsConfigureFlags                     (\_ -> return (error "unused"))                     elaboratedPlan@@ -1304,7 +1306,7 @@               Right br -> case buildResultTests br of                 TestsNotTried -> BuildReports.NotTried                 TestsOk -> BuildReports.Ok-         in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?+         in Just (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?       fromPlanPackage _ _ = Nothing       buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan @@ -1348,14 +1350,14 @@         unlines           [ case failureClassification of             ShowBuildSummaryAndLog reason _-              | verbosity > normal ->+              | verbosityLevel verbosity > Normal ->                   renderFailureDetail mentionDepOf pkg reason               | otherwise ->                   renderFailureSummary mentionDepOf pkg reason                     ++ ". See the build log above for details."             ShowBuildSummaryOnly reason ->               renderFailureDetail mentionDepOf pkg reason-          | let mentionDepOf = verbosity <= normal+          | let mentionDepOf = verbosityLevel verbosity <= Normal           , (pkg, failureClassification) <- failuresClassification           ]   where@@ -1370,7 +1372,7 @@       [ (pkg, classifyBuildFailure failure)       | (pkgid, failure) <- failures       , case buildFailureReason failure of-          DependentFailed{} -> verbosity > normal+          DependentFailed{} -> verbosityLevel verbosity > Normal           _ -> True       , InstallPlan.Configured pkg <-           maybeToList (InstallPlan.lookup plan pkgid)@@ -1499,9 +1501,9 @@     renderDependencyOf pkgid =       case ultimateDeps pkgid of         [] -> ""-        (p1 : []) ->+        [p1] ->           " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"-        (p1 : p2 : []) ->+        [p1, p2] ->           " (which is required by "             ++ elabPlanPackageName verbosity p1             ++ " and "
src/Distribution/Client/ProjectPlanOutput.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}  module Distribution.Client.ProjectPlanOutput   ( -- * Plan output@@ -66,8 +65,11 @@ import Distribution.Client.Compat.Prelude import Prelude () +import Control.Monad ((<=<))+ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BS+import Data.Either (fromRight) import qualified Data.Map as Map import qualified Data.Set as Set @@ -159,6 +161,11 @@         , "id" J..= (jdisplay . installedUnitId) elab         , "pkg-name" J..= (jdisplay . pkgName . packageId) elab         , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab+        , -- The `x-revision` field is a feature of repos (not cabal itself),+          -- but it's needed for external tools to unambiguously fetch+          -- packages without having to use index-state and go through+          -- the whole repo index, so we include it in the plan file.+          "pkg-revision" J..= J.Number (elaboratedPackageToRevision elab)         , "flags"             J..= J.object               [ PD.unFlagName fn J..= v@@ -186,7 +193,7 @@                     J.object $                       [ comp2str c                         J..= J.object-                          ( [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps)+                          ( [ "depends" J..= map ((jdisplay . confInstId) . fst) ldeps                             , "exe-depends" J..= map (jdisplay . confInstId) edeps                             ]                               ++ bin_file c@@ -199,7 +206,7 @@                       ]                in ["components" J..= components]             ElabComponent comp ->-              [ "depends" J..= map (jdisplay . confInstId) (map fst $ elabLibDependencies elab)+              [ "depends" J..= map ((jdisplay . confInstId) . fst) (elabLibDependencies elab)               , "exe-depends" J..= map jdisplay (elabExeDependencies elab)               , "component-name" J..= J.String (comp2str (compSolverName comp))               ]@@ -267,10 +274,18 @@                 , "uri" J..= J.String (show (remoteRepoURI repoRemote))                 ] +        elaboratedPackageToRevision :: ElaboratedConfiguredPackage -> Double+        elaboratedPackageToRevision =+          fromMaybe 0+            . (readMaybe <=< lookup "x-revision")+            . PD.customFieldsPD+            . elabPkgDescription+         sourceRepoToJ :: SourceRepoMaybe -> J.Value         sourceRepoToJ SourceRepositoryPackage{..} =           J.object $-            filter ((/= J.Null) . snd) $+            filter+              ((/= J.Null) . snd)               [ "type" J..= jdisplay srpType               , "location" J..= J.String srpLocation               , "branch" J..= fmap J.String srpBranch@@ -299,7 +314,7 @@                 then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat                 else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat -        flib_file' :: (Pretty a, Show a) => a -> [J.Pair]+        flib_file' :: Pretty a => a -> [J.Pair]         flib_file' s =           ["bin-file" J..= J.String bin]           where@@ -626,7 +641,7 @@           ]        elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]-      elabLibDeps = map (newSimpleUnitId . confInstId) . map fst . elabLibDependencies+      elabLibDeps = map ((newSimpleUnitId . confInstId) . fst) . elabLibDependencies        -- Was a build was attempted for this package?       -- If it doesn't have both a build status and outcome then the answer is no.@@ -651,27 +666,24 @@        packagesBuildLocal :: Set UnitId       packagesBuildLocal =-        selectPlanPackageIdSet $ \pkg ->-          case pkg of-            InstallPlan.PreExisting _ -> False-            InstallPlan.Installed _ -> False-            InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg+        selectPlanPackageIdSet $ \case+          InstallPlan.PreExisting _ -> False+          InstallPlan.Installed _ -> False+          InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg        packagesBuildInplace :: Set UnitId       packagesBuildInplace =-        selectPlanPackageIdSet $ \pkg ->-          case pkg of-            InstallPlan.PreExisting _ -> False-            InstallPlan.Installed _ -> False-            InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg)+        selectPlanPackageIdSet $ \case+          InstallPlan.PreExisting _ -> False+          InstallPlan.Installed _ -> False+          InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg)        packagesAlreadyInStore :: Set UnitId       packagesAlreadyInStore =-        selectPlanPackageIdSet $ \pkg ->-          case pkg of-            InstallPlan.PreExisting _ -> True-            InstallPlan.Installed _ -> True-            InstallPlan.Configured _ -> False+        selectPlanPackageIdSet $ \case+          InstallPlan.PreExisting _ -> True+          InstallPlan.Installed _ -> True+          InstallPlan.Configured _ -> False        selectPlanPackageIdSet         :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage@@ -765,10 +777,12 @@ readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =   handleDoesNotExist Set.empty $     handleDecodeFailure $-      withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd ->-        Binary.decodeOrFailIO =<< BS.hGetContents hnd+      withBinaryFile+        (distProjectCacheFile "up-to-date")+        ReadMode+        (Binary.decodeOrFailIO <=< BS.hGetContents)   where-    handleDecodeFailure = fmap (either (const Set.empty) id)+    handleDecodeFailure = fmap (fromRight Set.empty)  -- | Helper for writing the package up-to-date cache file. --
src/Distribution/Client/ProjectPlanning.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}  -- |@@ -109,6 +110,7 @@   , text   , vcat   , ($$)+  , ($+$)   ) import Prelude () @@ -121,7 +123,9 @@ import Distribution.Client.JobControl import Distribution.Client.PackageHash import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectConfig.Import (docProjectConfigFiles) import Distribution.Client.ProjectConfig.Legacy+import Distribution.Client.ProjectConfig.Types (defaultProjectFileParser) import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy   ( NonSetupLibDepSolverPlanPackage (..)@@ -136,7 +140,7 @@ import Distribution.Client.Store import Distribution.Client.Targets (userToPackageConstraint) import Distribution.Client.Types-import Distribution.Client.Utils (concatMapM, incVersion)+import Distribution.Client.Utils (concatMapM, duplicatesBy, incVersion)  import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.IndexUtils as IndexUtils@@ -221,10 +225,11 @@ import qualified Distribution.Compat.Graph as Graph  import Control.Exception (assert)-import Control.Monad (sequence)+import Control.Monad (mapM_, sequence) import Control.Monad.IO.Class (liftIO) import Control.Monad.State as State (State, execState, runState, state) import Data.Foldable (fold)+import Data.Functor ((<&>)) import Data.List (deleteBy, groupBy) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map@@ -264,11 +269,6 @@               == hashedInstalledPackageId                 (packageHashInputs sharedConfig elab)         )-      -- the stanzas explicitly disabled should not be available-      . assert-        ( optStanzaSetNull $-            optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable-        )       -- either a package is built inplace, or we are not attempting to       -- build any test suites or benchmarks (we never build these       -- for remote packages!)@@ -370,16 +370,17 @@     , distProjectFile     }   cliConfig = do-    progsearchpath <- liftIO $ getSystemSearchPath+    progsearchpath <- liftIO getSystemSearchPath      let fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config")      fileMonitorProjectConfigKey <- do-      configPath <- getConfigFilePath projectConfigConfigFile+      configPath <- getConfigFilePath verbosity projectConfigConfigFile       return         ( configPath-        , distProjectFile ""+        , distProjectFile ProjectFileKeyMain         , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg)+        , projectConfigProjectFileParser         , progsearchpath         , packageConfigProgramPaths         , packageConfigProgramPathExtra@@ -398,11 +399,11 @@           let fetchCompiler = do                 -- have to create the cache directory before configuring the compiler                 liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory-                (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)+                (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (snd (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)                 pure (os, arch, compiler)            (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton-          when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $+          when (projectConfigDistDir (projectConfigShared projectConfig) /= NoFlag) $             liftIO $               warn verbosity "The builddir option is not supported in project and config files. It will be ignored."           localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig)@@ -412,7 +413,7 @@      return (projectConfig <> cliConfig, localPackages)     where-      ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile} =+      ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile} =         projectConfigShared cliConfig        PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} =@@ -420,10 +421,12 @@        -- Read the cabal.project (or implicit config) and combine it with       -- arguments from the command line++      configFileParser = fromFlagOrDefault defaultProjectFileParser projectConfigProjectFileParser       --       phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton       phaseReadProjectConfig = do-        readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout+        readProjectConfig verbosity configFileParser httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout        -- Look for all the cabal packages in the project       -- some of which may be local src dirs, tarballs etc@@ -447,21 +450,37 @@             createDirectoryIfMissingVerbose verbosity True distDirectory             createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory -          fetchAndReadSourcePackages-            verbosity-            distDirLayout-            compiler-            projectConfigShared-            projectConfigBuildOnly-            pkgLocations+          sourcePackages <-+            fetchAndReadSourcePackages+              verbosity+              distDirLayout+              compiler+              projectConfigShared+              projectConfigBuildOnly+              pkgLocations +          case duplicatesBy (comparing srcpkgPackageId) [pkg | SpecificSourcePackage pkg <- sourcePackages] of+            [] -> return ()+            duplicateSourcePkgs ->+              liftIO $+                noticeDoc verbosity $+                  vcat+                    [ text "cabal project has multiple sources for"+                      <+> (pretty (srcpkgPackageId (head dupeGroup)) <> text ":")+                      $+$ Disp.nest 2 (vcat [pretty (srcpkgSource srcpkg) | srcpkg <- toList dupeGroup])+                      $+$ text "the choice of source that will be used is undefined."+                    | dupeGroup <- duplicateSourcePkgs+                    ]++          return sourcePackages+       informAboutConfigFiles projectConfig = do         cwd <- getCurrentDirectory         let out -- output mode is verbose ('notice') if we build outside the project root               | cwd == distProjectRootDirectory = info               | otherwise = notice         unless (null configFiles)-          . out (verboseStderr verbosity)+          . out (modifyVerbosityFlags verboseStderr verbosity)           . render           $ message         where@@ -483,7 +502,7 @@             where               configFilesDoc = map (quoteUntrimmed . projectConfigPathRoot) configFiles               configFilesVertList -- if verbose, include provenance ("imported by" stuff)-                | verbosity < verbose = docProjectConfigFiles configFiles+                | verbosityLevel verbosity < Verbose = docProjectConfigFiles configFiles                 | otherwise = vcat $ map (\p -> text "- " <> docProjectConfigPath p) configFiles               affectedByMsg = text "Configuration is affected by "               atProjectRootMsg = text "at '" <> text distProjectRootDirectory <> text "'."@@ -492,10 +511,20 @@             [ path             | Explicit path <-                 Set.toList-                  . (if verbosity >= verbose then id else onlyTopLevelProvenance)+                  . (if verbosityLevel verbosity >= Verbose then id else onlyTopLevelProvenance)                   $ projectConfigProvenance projectConfig             ] +-- | Configure the compiler. This results in a program database that contains+-- the **configured** compiler (which is stored in a cache)+-- and **unconfigured** related programs (cannot be cached, as unconfigured).+--+-- This will be re-run when the compiler or @hc-pkg@ change, and when the+-- program search path or @extra-prog-path@ or @program-locations@ change.+--+-- In the case of @GHC@, we configure @ghc@ and @ghc-pkg@, and provide+-- unconfigured attendant programs such as @hsc2hs@, @haddock@ and toolchain+-- programs such as @ar@, @ld@. See 'Distribution.Simple.GHC.configure'. configureCompiler   :: Verbosity   -> DistDirLayout@@ -522,7 +551,7 @@     } = do     let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" -    progsearchpath <- liftIO $ getSystemSearchPath+    progsearchpath <- liftIO getSystemSearchPath      (hc, plat, hcProgDb) <-       rerunIfChanged@@ -537,13 +566,13 @@         )         $ do           liftIO $ info verbosity "Compiler settings changed, reconfiguring..."-          progdb <--            liftIO $-              -- Add paths in the global config-              prependProgramSearchPath verbosity (fromNubList projectConfigProgPathExtra) [] defaultProgramDb-                -- Add paths in the local config-                >>= prependProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) []-                >>= pure . userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))+          progdb <- liftIO $ do+            -- Add paths in the global config then paths in the local config+            let addPaths pathList = prependProgramSearchPath verbosity (fromNubList pathList) []+            let globalPaths :: IO ProgramDb = addPaths projectConfigProgPathExtra defaultProgramDb+            let localPaths :: ProgramDb -> IO ProgramDb = addPaths packageConfigProgramPathExtra+            let userPaths :: ProgramDb -> ProgramDb = userSpecifyPaths (Map.toList $ getMapLast packageConfigProgramPaths)+            (globalPaths >>= localPaths) <&> userPaths           result@(_, _, progdb') <-             liftIO $               Cabal.configCompiler@@ -560,11 +589,15 @@           monitorFiles (programsMonitorFiles progdb')           return result -    -- Now, **outside** of the caching logic of 'rerunIfChanged', add on-    -- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...).+    -- Now, **outside** of the caching logic of 'rerunIfChanged':     --+    --  1. Call 'clearUnconfiguredPrograms' to ensure the consistency between+    --     the first run (in-memory) and when deserialising from cache.+    --  2. Add on auxiliary unconfigured programs to the ProgramDb+    --     (e.g. hsc2hs, haddock, ar, ld...).+    --     -- See Note [Caching the result of configuring the compiler]-    finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc hcProgDb hcPkg+    finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc (clearUnconfiguredPrograms hcProgDb) hcPkg     return (hc, plat, finalProgDb)     where       hcFlavor = flagToMaybe projectConfigHcFlavor@@ -593,6 +626,9 @@ a configured program, hence properly serialised/deserialised), and then re-compute any attendant unconfigured programs (such as hc-pkg, haddock or build tools such as ar, ld) using 'configCompilerProgDb'.+We also call 'clearUnconfiguredPrograms' on the ProgramDb returned by+'rerunIfChanged', so that the first-run (in-memory) result behaves the same as+the cache hit result: always drop unconfigured programs.  Another idea would be to simply eagerly configure all unconfigured programs, as was originally attempted. But this doesn't work, for a couple of reasons:@@ -653,7 +689,7 @@     { cabalStoreDirLayout     } = \projectConfig localPackages mbInstalledPackages ->     runRebuild distProjectRootDirectory $ do-      progsearchpath <- liftIO $ getSystemSearchPath+      progsearchpath <- liftIO getSystemSearchPath       let projectConfigMonitored = projectConfig{projectConfigBuildOnly = mempty}        -- The overall improved plan is cached@@ -736,14 +772,14 @@         :: ProjectConfig         -> (Compiler, Platform, ProgramDb)         -> Rebuild ()-      phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do+      phaseConfigurePrograms projectConfig (_, _, compilerProgDb) = do         -- Users are allowed to specify program locations independently for         -- each package (e.g. to use a particular version of a pre-processor         -- for some packages). However they cannot do this for the compiler         -- itself as that's just not going to work. So we check for this.         liftIO $           checkBadPerPackageCompilerPaths-            (configuredPrograms compilerprogdb)+            (configuredPrograms compilerProgDb)             (getMapMappend (projectConfigSpecificPackage projectConfig))        -- TODO: [required eventually] find/configure other programs that the@@ -887,7 +923,7 @@           , projectConfigSpecificPackage           , projectConfigBuildOnly           }-        (compiler, platform, progdb)+        (compiler, platform, compilerProgDb)         pkgConfigDB         solverPlan         localPackages = do@@ -901,14 +937,17 @@               $ getPackageSourceHashes verbosity withRepoCtx solverPlan            defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler-          let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared)+          let installDirs = fmap Cabal.fromFlag $ fmap Flag defaultInstallDirs <> projectConfigInstallDirs projectConfigShared+          -- Configure the compiler ProgramDb now (once for the entire project),+          -- to avoid repeatedly doing this once per package.+          configuredCompilerProgDb <- liftIO $ configureAllKnownPrograms verbosity compilerProgDb           (elaboratedPlan, elaboratedShared) <-             liftIO . runLogProgress verbosity $               elaborateInstallPlan                 verbosity                 platform                 compiler-                progdb+                configuredCompilerProgDb                 pkgConfigDB                 distDirLayout                 cabalStoreDirLayout@@ -1187,9 +1226,9 @@    (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $     liftIO $-      withRepoCtx $ \repoctx -> flip concatMapM (Map.toList repoTarballPkgsWithMetadataUnvalidatedMap) $-        \(repo, pkgids) ->-          verifyFetchedTarballs verbosity repoctx repo pkgids+      withRepoCtx $ \repoctx ->+        flip concatMapM (Map.toList repoTarballPkgsWithMetadataUnvalidatedMap) $+          uncurry (verifyFetchedTarballs verbosity repoctx)    -- For tarballs from repos that do not have hashes available we now have   -- to check if the packages were downloaded already.@@ -1242,8 +1281,8 @@                       ]                 | (repo, pkgids) <-                     map (\grp@((repo, _) :| _) -> (repo, map snd (NE.toList grp)))-                      . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . fst))-                      . sortBy (compare `on` (remoteRepoName . repoRemote . fst))+                      . NE.groupBy ((==) `on` (repoName . fst))+                      . sortBy (compare `on` (repoName . fst))                       $ repoTarballPkgsWithMetadata                 ] @@ -1348,7 +1387,7 @@           . setStrongFlags solverSettingStrongFlags           . setAllowBootLibInstalls solverSettingAllowBootLibInstalls           . setOnlyConstrained solverSettingOnlyConstrained-          . setSolverVerbosity verbosity+          . setSolverVerbosity (verbosityLevel verbosity)           -- TODO: [required eventually] decide if we need to prefer           -- installed for global packages, or prefer latest even for           -- global packages. Perhaps should be configurable but with a@@ -1365,6 +1404,7 @@           . removeLowerBounds solverSettingAllowOlder           . removeUpperBounds solverSettingAllowNewer           . addDefaultSetupDependencies+            setImplicitSetupInfo             ( mkDefaultSetupDeps comp platform                 . PD.packageDescription                 . srcpkgDescription@@ -1476,7 +1516,6 @@       -- GHC 8.4   needs  Cabal >= 2.2       -- GHC 8.2   needs  Cabal >= 2.0       -- GHC 8.0   needs  Cabal >= 1.24-      -- GHC 7.10  needs  Cabal >= 1.22       --       -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is       -- the absolute lower bound)@@ -1494,9 +1533,7 @@         | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4]         | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2]         | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0]-        | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24]-        | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22]-        | otherwise = mkVersion [1, 20]+        | otherwise = mkVersion [1, 24]         where           isGHC = compFlav `elem` [GHC, GHCJS]           compFlav = compilerFlavor comp@@ -1629,6 +1666,7 @@   -> Platform   -> Compiler   -> ProgramDb+  -- ^ __Configured__ compiler program database (ghc, ghc-pkg, haddock, ld, etc)   -> Maybe PkgConfigDb   -> DistDirLayout   -> StoreDirLayout@@ -1645,7 +1683,7 @@   verbosity   platform   compiler-  compilerprogdb+  compilerProgDb   pkgConfigDB   distDirLayout@DistDirLayout{..}   storeDirLayout@StoreDirLayout{storePackageDBStack}@@ -1664,7 +1702,7 @@         ElaboratedSharedConfig           { pkgConfigPlatform = platform           , pkgConfigCompiler = compiler-          , pkgConfigCompilerProgs = compilerprogdb+          , pkgConfigCompilerProgs = compilerProgDb           , pkgConfigReplOptions = mempty           } @@ -1677,10 +1715,9 @@             , not (IPI.indefinite ipkg) =                 Just                   ( IPI.installedUnitId ipkg-                  , ( FullUnitId-                        (IPI.installedComponentId ipkg)-                        (Map.fromList (IPI.instantiatedWith ipkg))-                    )+                  , FullUnitId+                      (IPI.installedComponentId ipkg)+                      (Map.fromList (IPI.instantiatedWith ipkg))                   )           f _ = Nothing @@ -1754,6 +1791,7 @@               -- new 'ElabSetup' type, and teach all of the code paths how to               -- handle it.               -- Once you've implemented this, swap it for the code below.+              -- (See #9986 for more information about this task.)               cuz_buildtype =                 case bt of                   PD.Configure -> []@@ -1761,9 +1799,12 @@                   -- main library in cabal. Other components will need to depend                   -- on the main library for configured data.                   PD.Custom -> [CuzBuildType CuzCustomBuildType]-                  PD.Hooks -> [CuzBuildType CuzHooksBuildType]-                  PD.Make -> [CuzBuildType CuzMakeBuildType]+                  PD.Make -> error "build-type: Make is no longer supported"                   PD.Simple -> []+                  -- TODO: remove the following, once we make Setup a separate+                  -- component (task tracked at #9986).+                  PD.Hooks -> [CuzBuildType CuzHooksBuildType]+               -- cabal-format versions prior to 1.8 have different build-depends semantics               -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8               -- see, https://github.com/haskell/cabal/issues/4121@@ -1903,7 +1944,7 @@                 -- correctly.                 let elab1 =                       elab0-                        { elabPkgOrComp = ElabComponent $ elab_comp+                        { elabPkgOrComp = ElabComponent elab_comp                         }                     cid = case elabBuildStyle elab0 of                       BuildInplaceOnly{} ->@@ -2043,9 +2084,7 @@                   distDirLayout                   elaboratedSharedConfig                   elab-                  $ case Cabal.componentNameString cname of-                    Just n -> prettyShow n-                    Nothing -> ""+                  $ maybe "" prettyShow (Cabal.componentNameString cname)        -- \| Given a 'SolverId' referencing a dependency on a library, return       -- the 'ElaboratedPlanPackage' corresponding to the library.  This@@ -2054,7 +2093,7 @@         :: (SolverId -> [ElaboratedPlanPackage])         -> SolverId         -> [ElaboratedPlanPackage]-      elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep+      elaborateLibSolverId mapDep = filter (matchPlanPkg (== CLibName LMainLibName)) . mapDep        -- \| Given an 'ElaboratedPlanPackage', return the paths to where the       -- executables that this package represents would be installed.@@ -2133,9 +2172,11 @@                       elab1                 } -            modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of-              Nothing -> emptyModuleShape-              Just e -> Ty.elabModuleShape e+            modShape =+              maybe+                emptyModuleShape+                Ty.elabModuleShape+                (find (matchElabPkg (== CLibName LMainLibName)) comps)              pkgInstalledId               | shouldBuildInplaceOnly pkg =@@ -2165,7 +2206,7 @@              -- TODO: Why is this flat?             pkgPkgConfigDependencies =-              CD.flatDeps $ buildComponentDeps compPkgConfigDependencies+              fold $ buildComponentDeps compPkgConfigDependencies              pkgDependsOnSelfLib =               CD.fromList@@ -2206,10 +2247,18 @@                 deps0                 _exe_deps0               ) =-          (elaboratedPackage, wayWarnings pkgid)+          (elaboratedPackage, wayWarnings pkgid >> buildOptionsAdjustmentWarnings)           where             elaboratedPackage = ElaboratedConfiguredPackage{..} +            buildOptionsAdjustmentWarnings :: LogProgress ()+            buildOptionsAdjustmentWarnings =+              mapM_ (warnProgress . text) $+                Cabal.buildOptionsAdjustmentWarnings+                  compiler+                  elabBuildOptionsRaw+                  elabBuildOptions+             -- These get filled in later             elabUnitId = error "elaborateSolverToCommon: elabUnitId"             elabComponentId = error "elaborateSolverToCommon: elabComponentId"@@ -2231,6 +2280,7 @@               gdesc of               Right (desc, _) -> desc               Left _ -> error "Failed to finalizePD in elaborateSolverToCommon"+            elabGPkgDescription = gdesc             elabFlagAssignment = flags             elabFlagDefaults =               PD.mkFlagAssignment@@ -2242,7 +2292,7 @@             elabStanzasAvailable = stanzas              elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)-            elabStanzasRequested = optStanzaTabulate $ \o -> case o of+            elabStanzasRequested = optStanzaTabulate $ \case               -- NB: even if a package stanza is requested, if the package               -- doesn't actually have any of that stanza we omit it from               -- the request, to ensure that we don't decide that this@@ -2311,7 +2361,14 @@              elabPkgDescriptionOverride = descOverride -            elabBuildOptions =+            -- Raw build options derived from per-package config.+            -- This is the cabal-install equivalent of Cabal's 'buildOptionsFromConfigFlags',+            -- except we have more information to go on than just ConfigFlags.+            --+            -- Options that depend on compiler and toolchain capabilities are+            -- passed through 'Cabal.adjustBuildOptions', so that+            -- 'elabBuildOptions' accurately reflects what will actually be built.+            elabBuildOptionsRaw =               LBC.BuildOptions                 { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively                 , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary@@ -2327,6 +2384,7 @@                 , withProfExe = profExe                 , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary                 , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared+                , withBytecodeLib = perPkgOptionFlag pkgid False packageConfigBytecodeLib                 , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage                 , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage                 , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization@@ -2342,6 +2400,8 @@             okProfDyn = profilingDynamicSupportedOrUnknown compiler             profExe = perPkgOptionFlag pkgid False packageConfigProf +            elabBuildOptions = Cabal.adjustBuildOptions compiler compilerProgDb elabBuildOptionsRaw+             ( elabProfExeDetail               , elabProfLibDetail               ) =@@ -2361,22 +2421,36 @@             elabProgramPaths =               Map.fromList                 [ (programId prog, programPath prog)-                | prog <- configuredPrograms compilerprogdb+                | prog <- configuredPrograms compilerProgDb                 ]                 <> perPkgOptionMapLast pkgid packageConfigProgramPaths             elabProgramArgs =-              Map.unionWith-                (++)-                ( Map.fromList-                    [ (programId prog, args)-                    | prog <- configuredPrograms compilerprogdb-                    , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog-                    , not (null args)-                    ]-                )-                (perPkgOptionMapMappend pkgid packageConfigProgramArgs)+              -- Workaround for <https://github.com/haskell/cabal/issues/4010>+              --+              -- It turns out that, even with Cabal 2.0, there's still cases such as e.g.+              -- custom Setup.hs scripts calling out to GHC even when going via+              -- @runProgram ghcProgram@, as e.g. happy does in its+              -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>+              -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)+              --+              -- So for now, let's pass the rather harmless and idempotent+              -- `-hide-all-packages` flag to all invocations (which has+              -- the benefit that every GHC invocation starts with a+              -- consistently well-defined clean slate) until we find a+              -- better way.+              Map.insertWith (++) "ghc" ["-hide-all-packages"] $+                Map.unionWith+                  (++)+                  ( Map.fromList+                      [ (programId prog, args)+                      | prog <- configuredPrograms compilerProgDb+                      , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog+                      , not (null args)+                      ]+                  )+                  (perPkgOptionMapMappend pkgid packageConfigProgramArgs)             elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra-            elabConfiguredPrograms = configuredPrograms compilerprogdb+            elabConfiguredPrograms = configuredPrograms compilerProgDb             elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs             elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs             elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic@@ -2485,7 +2559,7 @@        pkgsLocalToProject :: Set PackageId       pkgsLocalToProject =-        Set.fromList (catMaybes (map shouldBeLocal localPackages))+        Set.fromList (mapMaybe shouldBeLocal localPackages)       -- TODO: localPackages is a misnomer, it's all project packages       -- here is where we decide which ones will be local! @@ -2608,8 +2682,7 @@        packagesWithLibDepsDownwardClosedProperty property =         Set.fromList-          . map packageId-          . fromMaybe []+          . maybe [] (map packageId)           $ Graph.closure             libDepGraph             [ Graph.nodeKey pkg@@ -2859,10 +2932,9 @@       | Just planpkg <- Map.lookup cid cmap =           case planpkg of             InstallPlan.Configured-              ( elab0@ElaboratedConfiguredPackage-                  { elabPkgOrComp = ElabComponent comp-                  }-                ) -> do+              elab0@ElaboratedConfiguredPackage+                { elabPkgOrComp = ElabComponent comp+                } -> do                 deps <-                   traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)                 let build_style = fold (fmap snd insts)@@ -2878,7 +2950,7 @@                               ElabComponent                                 comp                                   { compOrderLibDependencies =-                                      (if Map.null insts then [] else [newSimpleUnitId cid])+                                      [newSimpleUnitId cid | not (Map.null insts)]                                         ++ ordNub                                           ( map                                               unDefUnitId@@ -2981,7 +3053,7 @@       | otherwise = error ("indefiniteComponent: " ++ prettyShow cid)      fixupBuildStyle BuildAndInstall elab = elab-    fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab+    fixupBuildStyle _ elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}} = elab     fixupBuildStyle t@(BuildInplaceOnly{}) elab =       elab         { elabBuildStyle = t@@ -2992,15 +3064,11 @@      ready_map = execState work Map.empty -    work = for_ pkgs $ \pkg ->-      case pkg of-        InstallPlan.Configured elab-          | not (Map.null (elabLinkedInstantiatedWith elab)) ->-              indefiniteUnitId (elabComponentId elab)-                >> return ()-        _ ->-          instantiateUnitId (getComponentId pkg) Map.empty-            >> return ()+    work = for_ pkgs $ \case+      InstallPlan.Configured elab+        | not (Map.null (elabLinkedInstantiatedWith elab)) ->+            void $ indefiniteUnitId (elabComponentId elab)+      pkg -> void $ instantiateUnitId (getComponentId pkg) Map.empty  --------------------------- -- Build targets@@ -3250,7 +3318,7 @@                 compComponentName elabComponent == Just cname               ElabPackage _ ->                 case componentName component of-                  CLibName (LMainLibName) -> True+                  CLibName LMainLibName -> True                   CExeName _ -> True                   -- TODO: what about sub-libs and foreign libs?                   _ -> False@@ -3267,8 +3335,7 @@   concatMap (wholeComponentOverrides . map snd)     . groupBy ((==) `on` fst)     . sortBy (compare `on` fst)-    . map (\t@((ComponentTarget cname _, _)) -> (cname, t))-    . map compatSubComponentTargets+    . map ((\t@(ComponentTarget cname _, _) -> (cname, t)) . compatSubComponentTargets)   where     -- If we're building the whole component then that the only target all we     -- need, otherwise we can have several targets within the component.@@ -3466,7 +3533,7 @@      -- Make a closed graph by calculating the closure from the roots     pruned_packages :: [ElaboratedPlanPackage]-    pruned_packages = map (mapConfiguredPackage fromPrunedPackage) (fromMaybe [] $ Graph.closure graph roots)+    pruned_packages = maybe [] (map (mapConfiguredPackage fromPrunedPackage)) (Graph.closure graph roots)      closed_graph :: Graph.Graph ElaboratedPlanPackage     closed_graph = Graph.fromDistinctList pruned_packages@@ -3491,7 +3558,7 @@     add_repl_target ecp       | elabUnitId ecp `Set.member` all_desired_repl_targets =           ecp-            { elabReplTarget = maybeToList (ComponentTarget <$> (elabComponentName ecp) <*> pure WholeComponent)+            { elabReplTarget = maybeToList (ComponentTarget <$> elabComponentName ecp <*> pure WholeComponent)             , elabBuildStyle = BuildInplaceOnly InMemory             }       | otherwise = ecp@@ -3573,7 +3640,7 @@     pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} =       InstallPlan.depends elab -- no pruning     pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} =-      (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)+      (fold . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)       where         keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas         keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas@@ -3734,7 +3801,7 @@       where         -- We initially assume that all the dependencies are external (hence the boolean is always         -- False) and here we correct the dependencies so the right packages are marked promised.-        addInternal (cid, _) = (cid, (cid `Set.member` inMemoryTargets))+        addInternal (cid, _) = (cid, cid `Set.member` inMemoryTargets)          libTargetsRequiredForRevDeps =           [ c@@ -3873,11 +3940,10 @@   -> DistDirLayout   -> SymbolicPath CWD (Dir Pkg)   -> SymbolicPath Pkg (Dir Dist)-  -> Bool   -> Lock   -> SetupScriptOptions -- TODO: Fix this so custom is a separate component.  Custom can ALWAYS--- be a separate component!!!+-- be a separate component!!! See #9986. setupHsScriptOptions   (ReadyPackage elab@ElaboratedConfiguredPackage{..})   plan@@ -3885,7 +3951,6 @@   distdir   srcdir   builddir-  isParallelBuild   cacheLock =     SetupScriptOptions       { useCabalVersion = thisVersion elabSetupScriptCliVersion@@ -3918,7 +3983,6 @@         -- for build-tools-depends.         useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan       , useWin32CleanHack = False -- TODO: [required eventually]-      , forceExternalSetupMethod = isParallelBuild       , setupCacheLock = Just cacheLock       , isInteractive = False       , isMainLibOrExeComponent = case elabPkgOrComp of@@ -3979,6 +4043,7 @@       dynlibdir         | buildOS == OSX = store </> "lib"         | otherwise = libdir+      bytecodelibdir = libdir       flibdir = libdir       libexecdir = prefix </> "libexec"       libexecsubdir = ""@@ -4054,10 +4119,11 @@         { configVanillaLib         , configSharedLib         , configStaticLib+        , configBytecodeLib         , configDynExe         , configFullyStaticExe         , configGHCiLib-        , -- , configProfExe -- overridden+        , -- configProfExe -- overridden         configProfLib         , configProfShared         , -- , configProf -- overridden@@ -4087,27 +4153,7 @@         ElabComponent _ -> toFlag elabComponentId        configProgramPaths = Map.toList elabProgramPaths-      configProgramArgs-        | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True =-            -- workaround for <https://github.com/haskell/cabal/issues/4010>-            ---            -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.-            -- custom Setup.hs scripts calling out to GHC even when going via-            -- @runProgram ghcProgram@, as e.g. happy does in its-            -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>-            -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)-            ---            -- So for now, let's pass the rather harmless and idempotent-            -- `-hide-all-packages` flag to all invocations (which has-            -- the benefit that every GHC invocation starts with a-            -- consistently well-defined clean slate) until we find a-            -- better way.-            Map.toList $-              Map.insertWith-                (++)-                "ghc"-                ["-hide-all-packages"]-                elabProgramArgs+      configProgramArgs = Map.toList elabProgramArgs       configProgramPathExtra = toNubList elabProgramPathExtra       configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler)       configHcPath = mempty -- we use configProgramPaths instead@@ -4116,12 +4162,12 @@        configConfigurationsFlags = elabFlagAssignment       configConfigureArgs = elabConfigureScriptArgs-      configExtraLibDirs = fmap makeSymbolicPath $ elabExtraLibDirs-      configExtraLibDirsStatic = fmap makeSymbolicPath $ elabExtraLibDirsStatic-      configExtraFrameworkDirs = fmap makeSymbolicPath $ elabExtraFrameworkDirs-      configExtraIncludeDirs = fmap makeSymbolicPath $ elabExtraIncludeDirs-      configProgPrefix = maybe mempty toFlag elabProgPrefix-      configProgSuffix = maybe mempty toFlag elabProgSuffix+      configExtraLibDirs = fmap makeSymbolicPath elabExtraLibDirs+      configExtraLibDirsStatic = fmap makeSymbolicPath elabExtraLibDirsStatic+      configExtraFrameworkDirs = fmap makeSymbolicPath elabExtraFrameworkDirs+      configExtraIncludeDirs = fmap makeSymbolicPath elabExtraIncludeDirs+      configProgPrefix = maybe (Flag (Cabal.toPathTemplate "")) toFlag elabProgPrefix+      configProgSuffix = maybe (Flag (Cabal.toPathTemplate "")) toFlag elabProgSuffix        configInstallDirs =         fmap@@ -4205,15 +4251,16 @@   :: Verbosity   -> Maybe (SymbolicPath CWD (Dir Pkg))   -> SymbolicPath Pkg (Dir Dist)+  -> [String]   -> Bool   -> Cabal.CommonSetupFlags-setupHsCommonFlags verbosity mbWorkDir builddir keepTempFiles =+setupHsCommonFlags verbosity mbWorkDir builddir targets keepTempFiles =   Cabal.CommonSetupFlags     { setupDistPref = toFlag builddir-    , setupVerbosity = toFlag verbosity+    , setupVerbosity = toFlag $ verbosityFlags verbosity     , setupCabalFilePath = mempty     , setupWorkingDir = maybeToFlag mbWorkDir-    , setupTargets = []+    , setupTargets = targets     , setupKeepTempFiles = toFlag keepTempFiles     } @@ -4253,11 +4300,11 @@ setupHsTestFlags (ElaboratedConfiguredPackage{..}) common =   Cabal.TestFlags     { testCommonFlags = common-    , testMachineLog = maybe mempty toFlag elabTestMachineLog-    , testHumanLog = maybe mempty toFlag elabTestHumanLog+    , testMachineLog = maybeToFlag elabTestMachineLog+    , testHumanLog = maybeToFlag elabTestHumanLog     , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails     , testKeepTix = toFlag elabTestKeepTix-    , testWrapper = maybe mempty toFlag elabTestWrapper+    , testWrapper = maybeToFlag elabTestWrapper     , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites     , testOptions = elabTestTestOptions     }@@ -4359,18 +4406,18 @@       , haddockProgramArgs = mempty -- unused, set at configure time       , haddockHoogle = toFlag elabHaddockHoogle       , haddockHtml = toFlag elabHaddockHtml-      , haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation+      , haddockHtmlLocation = maybeToFlag elabHaddockHtmlLocation       , haddockForHackage = toFlag elabHaddockForHackage       , haddockForeignLibs = toFlag elabHaddockForeignLibs       , haddockExecutables = toFlag elabHaddockExecutables       , haddockTestSuites = toFlag elabHaddockTestSuites       , haddockBenchmarks = toFlag elabHaddockBenchmarks       , haddockInternal = toFlag elabHaddockInternal-      , haddockCss = maybe mempty toFlag elabHaddockCss+      , haddockCss = maybeToFlag elabHaddockCss       , haddockLinkedSource = toFlag elabHaddockLinkedSource       , haddockQuickJump = toFlag elabHaddockQuickJump-      , haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss-      , haddockContents = maybe mempty toFlag elabHaddockContents+      , haddockHscolourCss = maybeToFlag elabHaddockHscolourCss+      , haddockContents = maybeToFlag elabHaddockContents       , haddockIndex = maybe mempty toFlag elabHaddockIndex       , haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl       , haddockResourcesDir = maybe mempty toFlag elabHaddockResourcesDir@@ -4502,6 +4549,7 @@     , pkgHashProfExe = withProfExe     , pkgHashProfLibDetail = withProfLibDetail     , pkgHashProfExeDetail = withProfExeDetail+    , pkgHashBytecodeLib = withBytecodeLib     , pkgHashCoverage = exeCoverage     , pkgHashOptimization = withOptimization     , pkgHashSplitSections = splitSections
src/Distribution/Client/ProjectPlanning/SetupPolicy.hs view
@@ -212,9 +212,7 @@     Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))   where     setupLibDeps =-      map packageId $-        fromMaybe [] $-          Graph.closure libDepGraph (CD.setupDeps deps)+      maybe [] (map packageId) (Graph.closure libDepGraph (CD.setupDeps deps))  cabalPkgname :: PackageName cabalPkgname = mkPackageName "Cabal"@@ -239,9 +237,5 @@       ++ ["unix" | os /= Windows]       ++ ["ghc-prim" | isGHC]       ++ ["template-haskell" | isGHC]-      ++ ["old-time" | notGHC710]   where     isGHC = compilerCompatFlavor GHC compiler-    notGHC710 = case compilerCompatVersion GHC compiler of-      Nothing -> False-      Just v -> v <= mkVersion [7, 9]
src/Distribution/Client/ProjectPlanning/Types.hs view
@@ -116,13 +116,14 @@ import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion import Distribution.Utils.Path (getSymbolicPath)-import Distribution.Verbosity (normal) import Distribution.Version  import qualified Data.ByteString.Lazy as LBS+import Data.Foldable (fold) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Monoid as Mon+import Distribution.Verbosity import System.FilePath ((</>)) import Text.PrettyPrint (hsep, parens, text) @@ -145,7 +146,7 @@ -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg)-  | verbosity <= normal = prettyShow (packageName ipkg)+  | verbosityLevel verbosity <= Normal = prettyShow (packageName ipkg)   | otherwise = prettyShow (installedUnitId ipkg) elabPlanPackageName verbosity (Configured elab) =   elabConfiguredName verbosity elab@@ -162,13 +163,12 @@         }       where         herald =-          ( hsep-              [ text (InstallPlan.showPlanPackageTag pkg)-              , InstallPlan.foldPlanPackage (const mempty) in_mem pkg-              , pretty (packageId pkg)-              , parens (pretty (nodeKey pkg))-              ]-          )+          hsep+            [ text (InstallPlan.showPlanPackageTag pkg)+            , InstallPlan.foldPlanPackage (const mempty) in_mem pkg+            , pretty (packageId pkg)+            , parens (pretty (nodeKey pkg))+            ]          in_mem elab = case elabBuildStyle elab of           BuildInplaceOnly InMemory -> parens (text "In Memory")@@ -187,9 +187,10 @@   { pkgConfigPlatform :: Platform   , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo   , pkgConfigCompilerProgs :: ProgramDb-  -- ^ The programs that the compiler configured (e.g. for GHC, the progs-  -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are-  -- used.+  -- ^ All known programs configured once for the project: the compiler+  -- (e.g. ghc & ghc-pkg) plus associated tools (hsc2hs, haddock, hpc,+  -- runghc) and toolchain programs (ar, ld, strip). Once constructed,+  -- only the 'configuredPrograms' are used.   , pkgConfigReplOptions :: ReplOptions   }   deriving (Show, Generic)@@ -223,6 +224,8 @@   , elabFlagDefaults :: Cabal.FlagAssignment   -- ^ The original default flag assignment, used only for reporting.   , elabPkgDescription :: Cabal.PackageDescription+  , elabGPkgDescription :: Cabal.GenericPackageDescription+  -- ^ Original 'GenericPackageDescription' (just used to report errors/warnings)   , elabPkgSourceLocation :: PackageLocation (Maybe FilePath)   -- ^ Where the package comes from, e.g. tarball, local dir etc. This   --   is not the same as where it may be unpacked to for the build.@@ -433,12 +436,11 @@   -> ElaboratedInstallPlan   -> [(String, Maybe FilePath)] dataDirsEnvironmentForPlan distDirLayout =-  catMaybes-    . fmap-      ( InstallPlan.foldPlanPackage-          (const Nothing)-          (dataDirEnvVarForPackage distDirLayout)-      )+  mapMaybe+    ( InstallPlan.foldPlanPackage+        (const Nothing)+        (dataDirEnvVarForPackage distDirLayout)+    )     . InstallPlan.toList  -- | Construct an environment variable that points@@ -518,7 +520,7 @@ -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab-  | verbosity <= normal =+  | verbosityLevel verbosity <= Normal =       ( case elabPkgOrComp elab of           ElabPackage _ -> ""           ElabComponent comp ->@@ -559,7 +561,7 @@   case elabPkgOrComp elab of     -- Important not to have duplicates: otherwise InstallPlan gets     -- confused.-    ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))+    ElabPackage pkg -> ordNub (fold (pkgOrderDependencies pkg))     ElabComponent comp -> compOrderDependencies comp  -- | Like 'elabOrderDependencies', but only returns dependencies on@@ -570,7 +572,7 @@     ElabPackage pkg ->       map (newSimpleUnitId . confInstId) $         ordNub $-          CD.flatDeps (map fst <$> pkgLibDependencies pkg)+          fold (map fst <$> pkgLibDependencies pkg)     ElabComponent comp -> compOrderLibDependencies comp  -- | The library dependencies (i.e., the libraries we depend on, NOT@@ -764,7 +766,6 @@   = CuzConfigureBuildType   | CuzCustomBuildType   | CuzHooksBuildType-  | CuzMakeBuildType   deriving (Eq, Show, Generic)  instance Binary NotPerComponentBuildType@@ -782,7 +783,6 @@       CuzConfigureBuildType -> "Configure"       CuzCustomBuildType -> "Custom"       CuzHooksBuildType -> "Hooks"-      CuzMakeBuildType -> "Make"   CuzCabalSpecVersion -> "cabal-version is less than 1.8"   CuzNoBuildableComponents -> "there are no buildable components"   CuzDisablePerComponent -> "you passed --disable-per-component"
src/Distribution/Client/RebuildMonad.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -69,7 +68,7 @@ import Distribution.Client.JobControl import Distribution.Simple.PreProcess.Types (Suffix (..)) -import Distribution.Simple.Utils (debug)+import Distribution.Simple.Utils (debug, ordNub)  import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) import Control.Monad@@ -221,12 +220,11 @@   where     getOrInitResource :: MVar (Maybe a) -> IO a     getOrInitResource var =-      modifyMVar var $ \mx ->-        case mx of-          Just x -> return (Just x, x)-          Nothing -> do-            x <- action-            return (Just x, x)+      modifyMVar var $ \case+        Just x -> return (Just x, x)+        Nothing -> do+          x <- action+          return (Just x, x)  -- | Much like 'delayInitSharedResource' but for a keyed set of resources. --@@ -270,7 +268,7 @@ getDirectoryContentsMonitored dir = do   exists <- monitorDirectoryStatus dir   if exists-    then liftIO $ getDirectoryContents dir+    then liftIO $ listDirectory dir     else return []  createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()@@ -332,8 +330,8 @@   findFirstFileMonitored     id     [ path </> baseName <.> ext-    | path <- nub searchPath-    , Suffix ext <- nub extensions+    | path <- ordNub searchPath+    , Suffix ext <- ordNub extensions     ]  -- | Like 'findFirstFile', but in the 'Rebuild' monad.@@ -354,5 +352,5 @@   findFirstFileMonitored     id     [ path </> fileName-    | path <- nub searchPath+    | path <- ordNub searchPath     ]
src/Distribution/Client/Reconfigure.hs view
@@ -15,10 +15,10 @@   , info   ) import Distribution.Utils.Path+import Distribution.Verbosity  import Distribution.Client.Config (SavedConfig (..)) import Distribution.Client.Configure (readConfigFlags)-import Distribution.Client.Nix (findNixExpr, inNixShell, nixInstantiate) import Distribution.Client.Sandbox (findSavedDistPref, updateInstallDirs) import Distribution.Client.Sandbox.PackageEnvironment   ( userPackageEnvironmentFile@@ -110,37 +110,19 @@     do       savedFlags@(_, _) <- readConfigFlags $ getSymbolicPath dist -      useNix <- fmap isJust (findNixExpr globalFlags config)-      alreadyInNixShell <- inNixShell--      if useNix && not alreadyInNixShell-        then do-          -- If we are using Nix, we must reinstantiate the derivation outside-          -- the shell. Eventually, the caller will invoke 'nixShell' which will-          -- rerun cabal inside the shell. That will bring us back to 'reconfigure',-          -- but inside the shell we'll take the second branch, below.--          -- This seems to have a problem: won't 'configureAction' call 'nixShell'-          -- yet again, spawning an infinite tree of subprocesses?-          -- No, because 'nixShell' doesn't spawn a new process if it is already-          -- running in a Nix shell.--          nixInstantiate verbosity (getSymbolicPath dist) False globalFlags config-          return config-        else do-          let checks :: Check (ConfigFlags, ConfigExFlags)-              checks =-                checkVerb-                  <> checkDist-                  <> checkOutdated-                  <> check-          (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags+      let checks :: Check (ConfigFlags, ConfigExFlags)+          checks =+            checkVerb+              <> checkDist+              <> checkOutdated+              <> check+      (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags -          let config' :: SavedConfig-              config' = updateInstallDirs (configUserInstall configFlags) config+      let config' :: SavedConfig+          config' = updateInstallDirs (configUserInstall configFlags) config -          when frc $ configureAction flags extraArgs globalFlags-          return config'+      when frc $ configureAction flags extraArgs globalFlags+      return config'     where       mbWorkDir = flagToMaybe $ configWorkingDir $ savedConfigureFlags config       -- Changing the verbosity does not require reconfiguration, but the new@@ -152,7 +134,7 @@             configFlags' =               configFlags                 { configCommonFlags =-                    common{setupVerbosity = toFlag verbosity}+                    common{setupVerbosity = toFlag $ verbosityFlags verbosity}                 }         return (mempty, (configFlags', configExFlags))
src/Distribution/Client/Run.hs view
@@ -1,8 +1,3 @@-------------------------------------------------------------------------------{-# LANGUAGE DataKinds #-}-------------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Run -- Maintainer  :  cabal-devel@haskell.org@@ -80,7 +75,7 @@             " Interpreting all parameters to `run` as a parameter to"               ++ " the default executable."       -- If there is a warning, print it together with the addition.-      warn verbosity `traverse_` fmap (++ addition) maybeWarning+      traverse_ (warn verbosity . (++ addition)) maybeWarning       return (exe, xs)   where     pkg_descr = localPkgDescr lbi@@ -94,7 +89,7 @@     whichExecutable = case (enabledExes, args) of       ([], _) -> Left "Couldn't find any enabled executables."       ([exe], []) -> return (False, exe, [])-      ([exe], (x : xs))+      ([exe], x : xs)         | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)         | otherwise -> return (False, exe, args)       (_, []) ->@@ -102,7 +97,7 @@           "This package contains multiple executables. "             ++ "You must pass the executable name as the first argument "             ++ "to 'cabal run'."-      (_, (x : xs)) ->+      (_, x : xs) ->         case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of           Nothing -> Left $ "No executable named '" ++ x ++ "'."           Just exe -> return (True, exe, xs)
src/Distribution/Client/Sandbox.hs view
@@ -123,7 +123,7 @@ findSavedDistPref config flagDistPref = do   let defDistPref = useDistPref defaultSetupScriptOptions       flagDistPref' =-        (setupDistPref (configCommonFlags $ savedConfigureFlags config))+        setupDistPref (configCommonFlags $ savedConfigureFlags config)           `mappend` flagDistPref   findDistPref defDistPref flagDistPref'
src/Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}  ----------------------------------------------------------------------------- @@ -172,7 +172,7 @@   [ commaNewLineListFieldParsec       "constraints"       (pretty . fst)-      ((\pc -> (pc, src)) `fmap` parsec)+      ((,src) `fmap` parsec)       ( sortConstraints           . configExConstraints           . savedConfigureExFlags@@ -345,7 +345,7 @@ -- | Pretty-print the package environment with default values for empty fields -- commented out (just like the default Cabal config file). showPackageEnvironmentWithComments-  :: (Maybe PackageEnvironment)+  :: Maybe PackageEnvironment   -> PackageEnvironment   -> String showPackageEnvironmentWithComments mdefPkgEnv pkgEnv =
src/Distribution/Client/SavedFlags.hs view
@@ -22,7 +22,7 @@ writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () writeSavedArgs verbosity path args = do   createDirectoryIfMissingVerbose-    (lessVerbose verbosity)+    (modifyVerbosityFlags lessVerbose verbosity)     True     (takeDirectory path)   writeFile path (intercalate "\0" args)@@ -48,7 +48,7 @@ readCommandFlags :: FilePath -> CommandUI flags -> IO flags readCommandFlags path command = do   savedArgs <- fmap (fromMaybe []) (readSavedArgs path)-  case (commandParseArgs command True savedArgs) of+  case commandParseArgs command True savedArgs of     CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)     CommandList _ -> throwIO (SavedArgsErrorList savedArgs)     CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)@@ -69,13 +69,13 @@ instance Show SavedArgsError where   show (SavedArgsErrorHelp args) =     "unexpected flag '--help', saved command line was:\n"-      ++ intercalate " " args+      ++ unwords args   show (SavedArgsErrorList args) =     "unexpected flag '--list-options', saved command line was:\n"-      ++ intercalate " " args+      ++ unwords args   show (SavedArgsErrorOther args errs) =     "saved command line was:\n"-      ++ intercalate " " args+      ++ unwords args       ++ "\n"       ++ "encountered errors:\n"       ++ intercalate "\n" errs
src/Distribution/Client/ScriptUtils.hs view
@@ -12,6 +12,7 @@   , withContextAndSelectors   , AcceptNoTargets (..)   , TargetContext (..)+  , TargetsAction   , updateContextAndWriteProjectFile   , updateContextAndWriteProjectFile'   , fakeProjectSourcePackage@@ -57,9 +58,9 @@   , withGlobalConfig   , withProjectOrGlobalConfig   )+import Distribution.Client.ProjectConfig.Import (ProjectConfigSkeleton, reportDuplicateImports) import Distribution.Client.ProjectConfig.Legacy-  ( ProjectConfigSkeleton-  , instantiateProjectConfigSkeletonFetchingCompiler+  ( instantiateProjectConfigSkeletonFetchingCompiler   , parseProject   ) import Distribution.Client.ProjectConfig.Types (ProjectConfigToParse (..))@@ -91,6 +92,9 @@   ( CompilerId (..)   , perCompilerFlavorToList   )+import qualified Distribution.Deprecated.ProjectParseUtils as OldParser+  ( ProjectParseResult (..)+  ) import Distribution.FieldGrammar   ( parseFieldGrammar   , takeFields@@ -131,7 +135,6 @@   ( createDirectoryIfMissingVerbose   , createTempDirectory   , dieWithException-  , handleDoesNotExist   , readUTF8File   , warn   , writeUTF8File@@ -198,7 +201,7 @@   ( canonicalizePath   , doesFileExist   , getTemporaryDirectory-  , removeDirectoryRecursive+  , removePathForcibly   ) import System.FilePath   ( makeRelative@@ -269,6 +272,9 @@     ScriptContext FilePath Executable   deriving (Eq, Show) +-- | An action working with selected targets within a context.+type TargetsAction targets a = TargetContext -> ProjectBaseContext -> targets -> IO a+ -- | Determine whether the targets represent regular targets or a script -- and return the proper context and target selectors. -- Die with an error message if selectors are valid as neither regular targets or as a script.@@ -289,8 +295,7 @@   -- ^ Global flags.   -> CurrentCommand   -- ^ Current Command (usually for error reporting).-  -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)-  -- ^ The body of your command action.+  -> TargetsAction [TargetSelector] b   -> IO b withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act =   withTemporaryTempDirectory $ \mkTmpDir -> do@@ -326,7 +331,7 @@             | TargetString1 script <- t -> scriptOrError script err           Left err@(TargetSelectorExpected t _ _ : _)             | TargetString1 script <- t -> scriptOrError script err-          Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name.+          Left err@(MatchingInternalError{} : _) -- Handle ':' in middle of script name.             | [script] <- targetStrings -> scriptOrError script err           Left err -> reportTargetSelectorProblems verbosity err           Right sels -> return (tc, ctx, sels)@@ -374,13 +379,13 @@           projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents            createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)-          (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)+          (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (snd (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)            (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton            let ctx' = ctx & lProjectConfig %~ (<> projectCfg) -              build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform+              build_dir = distBuildDirectory (distDirLayout ctx') $ scriptDistDirParams script ctx' compiler platform               exePath = build_dir </> "bin" </> scriptExeFileName script               exePathRel = makeRelative (normalise projectRoot) exePath @@ -407,7 +412,7 @@       let tmpDir = tmpBaseDir </> tmpRelDir       putMVar m tmpDir       return tmpDir-    rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive)+    rmTmp m _ = tryTakeMVar m >>= maybe (return ()) removePathForcibly  scriptComponentName :: IsString s => FilePath -> s scriptComponentName scriptPath = fromString cname@@ -470,14 +475,14 @@     sourcePackage =       fakeProjectSourcePackage projectRoot         & lSrcpkgDescription . L.condExecutables-          .~ [(scriptComponentName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])]+          .~ [(scriptComponentName scriptPath, CondNode executable [])]     executable =       scriptExecutable         & L.modulePath .~ absScript    updateContextAndWriteProjectFile' ctx sourcePackage -parseScriptBlock :: BS.ByteString -> ParseResult Executable+parseScriptBlock :: BS.ByteString -> ParseResult src Executable parseScriptBlock str =   case readFields str of     Right fs -> do@@ -519,9 +524,12 @@ readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do   case extractScriptBlock "project" str of     Left _ -> return mempty-    Right x ->-      reportParseResult verbosity "script" scriptName-        =<< parseProject scriptName distDownloadSrcDirectory httpTransport verbosity (ProjectConfigToParse x)+    Right bs -> do+      res <- parseProject scriptName distDownloadSrcDirectory httpTransport verbosity (ProjectConfigToParse bs)+      case res of+        OldParser.ProjectParseOk _ skeleton -> reportDuplicateImports verbosity skeleton+        OldParser.ProjectParseFailed{} -> pure ()+      reportParseResult verbosity "script" scriptName res  -- | Extract the first encountered script metadata block started end -- terminated by the tokens
src/Distribution/Client/Security/HTTP.hs view
@@ -197,7 +197,6 @@   -> (HC.Throws HC.SomeRemoteError => IO a) wrapCustomEx act =   HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) $-    HC.handleChecked (\(ex :: IOException) -> go ex) $-      act+    HC.handleChecked (\(ex :: IOException) -> go ex) act   where     go ex = HC.throwChecked (HC.SomeRemoteError ex)
src/Distribution/Client/Setup.hs view
@@ -103,6 +103,7 @@ import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDeps (..)) import Distribution.Client.Types.Credentials (Password (..), Token (..), Username (..)) import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..))+import Distribution.Client.Types.RepoName import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy  import Distribution.Client.BuildReports.Types@@ -227,7 +228,9 @@   ( unqualComponentNameToPackageName   ) import Distribution.Verbosity-  ( lessVerbose+  ( VerbosityFlags+  , defaultVerbosityHandles+  , lessVerbose   , normal   , verboseNoFlags   , verboseNoTimestamp@@ -489,6 +492,13 @@           trueArg       , option           []+          ["full-version"]+          "Print full version information with git revision (if available) and compiler"+          globalFullVersion+          (\v flags -> flags{globalFullVersion = v})+          trueArg+      , option+          []           ["numeric-version"]           "Print just the version number"           globalNumericVersion@@ -515,32 +525,6 @@           globalHttpTransport           (\v flags -> flags{globalHttpTransport = v})           (reqArgFlag "HttpTransport")-      , multiOption-          "nix"-          globalNix-          (\v flags -> flags{globalNix = v})-          [ optArg'-              "(True or False)"-              (maybeToFlag . (readMaybe =<<))-              ( \case-                  Flag True -> [Just "enable"]-                  Flag False -> [Just "disable"]-                  NoFlag -> []-              )-              ""-              ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr-              "[DEPRECATED] Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)"-          , noArg-              (Flag True)-              []-              ["enable-nix"]-              "[DEPRECATED] Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists"-          , noArg-              (Flag False)-              []-              ["disable-nix"]-              "[DEPRECATED] Disable Nix integration"-          ]       , option           []           ["store-dir", "storedir"]@@ -696,7 +680,7 @@ filterConfigureFlags' flags cabalLibVersion   -- NB: we expect the latest version to be the most common case,   -- so test it first.-  | cabalLibVersion >= mkVersion [3, 13, 0] = flags_latest+  | cabalLibVersion >= mkVersion [3, 17, 0] = flags_latest   -- The naming convention is that flags_version gives flags with   -- all flags *introduced* in version eliminated.   -- It is NOT the latest version of Cabal library that@@ -719,6 +703,7 @@   | cabalLibVersion < mkVersion [3, 7, 0] = flags_3_7_0   | cabalLibVersion < mkVersion [3, 11, 0] = flags_3_11_0   | cabalLibVersion < mkVersion [3, 13, 0] = flags_3_13_0+  | cabalLibVersion < mkVersion [3, 17, 0] = flags_3_17_0   | otherwise = error "the impossible just happened" -- see first guard   where     flags_latest =@@ -730,6 +715,12 @@           configConstraints = []         } +    flags_3_17_0 =+      flags_latest+        { configBytecodeLib = NoFlag+        , configInstallDirs = (configInstallDirs flags){bytecodelibdir = NoFlag}+        }+     flags_3_13_0 =       let scrubVersion pc =             pc@@ -737,7 +728,7 @@                   (promisedComponentPackage pc){pkgVersion = nullVersion}               }        in -- Earlier Cabal versions don't understand about ..-          flags_latest+          flags_3_17_0             { -- Building profiled shared libraries               configProfShared = NoFlag             , configIgnoreBuildTools = NoFlag@@ -784,7 +775,7 @@                       cid                 convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =                   Just $ GivenComponent pn LMainLibName cid-             in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags+             in mapMaybe convertToLegacyInternalDep (configDependencies flags)         , -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.           configAllowDependingOnPrivateLibs = NoFlag         , -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.@@ -897,6 +888,7 @@ configCompilerAux' configFlags = do   let commonFlags = configCommonFlags configFlags   configCompilerAuxEx+    defaultVerbosityHandles     configFlags       { -- FIXME: make configCompilerAux use a sensible verbosity         configCommonFlags =@@ -1016,7 +1008,7 @@   , option       []       ["allow-older"]-      ("Ignore lower bounds in all dependencies or DEPS")+      "Ignore lower bounds in all dependencies or DEPS"       (fmap unAllowOlder . configAllowOlder)       (\v flags -> flags{configAllowOlder = fmap AllowOlder v})       ( optArg@@ -1028,7 +1020,7 @@   , option       []       ["allow-newer"]-      ("Ignore upper bounds in all dependencies or DEPS")+      "Ignore upper bounds in all dependencies or DEPS"       (fmap unAllowNewer . configAllowNewer)       (\v flags -> flags{configAllowNewer = fmap AllowNewer v})       ( optArg@@ -1082,10 +1074,10 @@           ++ "packages to use newer versions."     else return . Just . RelaxDepsSome . toList $ rs -relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]+relaxDepsPrinter :: Maybe RelaxDeps -> [Maybe String] relaxDepsPrinter Nothing = [] relaxDepsPrinter (Just RelaxDepsAll) = [Nothing]-relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs+relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) pkgs  instance Monoid ConfigExFlags where   mempty = gmempty@@ -1140,8 +1132,7 @@             ++ "Affected by configuration options, see `v1-configure`.\n"     , commandDefaultFlags = commandDefaultFlags parent     , commandUsage =-        usageAlternatives "v1-build" $-          ["[FLAGS]", "COMPONENTS [FLAGS]"]+        usageAlternatives "v1-build" ["[FLAGS]", "COMPONENTS [FLAGS]"]     , commandOptions = commandOptions parent     , commandNotes = Just $ \pname ->         "Examples:\n"@@ -1417,7 +1408,7 @@   , fetchOnlyConstrained :: Flag OnlyConstrained   , fetchTests :: Flag Bool   , fetchBenchmarks :: Flag Bool-  , fetchVerbosity :: Flag Verbosity+  , fetchVerbosity :: Flag VerbosityFlags   }  defaultFetchFlags :: FetchFlags@@ -1550,7 +1541,7 @@   , freezeStrongFlags :: Flag StrongFlags   , freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls   , freezeOnlyConstrained :: Flag OnlyConstrained-  , freezeVerbosity :: Flag Verbosity+  , freezeVerbosity :: Flag VerbosityFlags   }  defaultFreezeFlags :: FreezeFlags@@ -1680,7 +1671,7 @@ -- ------------------------------------------------------------  data CheckFlags = CheckFlags-  { checkVerbosity :: Flag Verbosity+  { checkVerbosity :: Flag VerbosityFlags   , checkIgnore :: [CheckExplanationIDString]   }   deriving (Show)@@ -1732,7 +1723,7 @@ -- ------------------------------------------------------------  data UpdateFlags = UpdateFlags-  { updateVerbosity :: Flag Verbosity+  { updateVerbosity :: Flag VerbosityFlags   , updateIndexState :: Flag TotalIndexState   }   deriving (Generic)@@ -1757,7 +1748,7 @@         "Usage: " ++ pname ++ " v1-clean [FLAGS]\n"     } -formatCommand :: CommandUI (Flag Verbosity)+formatCommand :: CommandUI (Flag VerbosityFlags) formatCommand =   CommandUI     { commandName = "format"@@ -1827,7 +1818,8 @@   { reportToken :: Flag Token   , reportUsername :: Flag Username   , reportPassword :: Flag Password-  , reportVerbosity :: Flag Verbosity+  , reportVerbosity :: Flag VerbosityFlags+  , reportRepoName :: Flag RepoName   }   deriving (Generic) @@ -1838,6 +1830,7 @@     , reportUsername = mempty     , reportPassword = mempty     , reportVerbosity = toFlag normal+    , reportRepoName = mempty     }  reportCommand :: CommandUI ReportFlags@@ -1886,6 +1879,13 @@                 (toFlag . Password)                 (flagToList . fmap unPassword)             )+        , option+            ['R']+            ["repository"]+            "Package repository to upload to."+            reportRepoName+            (\v flags -> flags{reportRepoName = v})+            (reqArg' "REPOSITORY" (toFlag . RepoName) (flagToList . fmap unRepoName))         ]     } @@ -1909,7 +1909,8 @@   , getIndexState :: Flag TotalIndexState   , getActiveRepos :: Flag ActiveRepos   , getSourceRepository :: Flag (Maybe RepoKind)-  , getVerbosity :: Flag Verbosity+  , getVerbosity :: Flag VerbosityFlags+  , getRepoName :: Flag RepoName   }   deriving (Generic) @@ -1923,6 +1924,7 @@     , getActiveRepos = mempty     , getSourceRepository = mempty     , getVerbosity = toFlag normal+    , getRepoName = mempty     }  getCommand :: CommandUI GetFlags@@ -2005,6 +2007,13 @@             getPristine             (\v flags -> flags{getPristine = v})             trueArg+        , option+            ['R']+            ["repository"]+            "Package repository to fetch from."+            getRepoName+            (\v flags -> flags{getRepoName = v})+            (reqArg' "REPOSITORY" (toFlag . RepoName) (flagToList . fmap unRepoName))         ]     } @@ -2063,7 +2072,7 @@   { listInstalled :: Flag Bool   , listSimpleOutput :: Flag Bool   , listCaseInsensitive :: Flag Bool-  , listVerbosity :: Flag Verbosity+  , listVerbosity :: Flag VerbosityFlags   , listPackageDBs :: [Maybe PackageDB]   , listHcPath :: Flag FilePath   }@@ -2173,7 +2182,7 @@ -- ------------------------------------------------------------  data InfoFlags = InfoFlags-  { infoVerbosity :: Flag Verbosity+  { infoVerbosity :: Flag VerbosityFlags   , infoPackageDBs :: [Maybe PackageDB]   }   deriving (Generic)@@ -2394,7 +2403,7 @@           ++ pname           ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"           ++ "  "-          ++ (map (const ' ') pname)+          ++ map (const ' ') pname           ++ "                         "           ++ "    Change installation destination\n"     , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty)@@ -2451,8 +2460,7 @@ haddockCommand =   Cabal.haddockCommand     { commandUsage =-        usageAlternatives "v1-haddock" $-          ["[FLAGS]", "COMPONENTS [FLAGS]"]+        usageAlternatives "v1-haddock" ["[FLAGS]", "COMPONENTS [FLAGS]"]     }  filterHaddockArgs :: [String] -> Version -> [String]@@ -2629,7 +2637,7 @@       ( reqArg           "DATABASE"           (succeedReadE (Flag . Cabal.CopyToDb))-          (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])+          (\case Flag (Cabal.CopyToDb p) -> [p]; _ -> [])       )   ]     ++ optionSolverFlags@@ -2880,7 +2888,8 @@   , uploadUsername :: Flag Username   , uploadPassword :: Flag Password   , uploadPasswordCmd :: Flag [String]-  , uploadVerbosity :: Flag Verbosity+  , uploadVerbosity :: Flag VerbosityFlags+  , uploadRepoName :: Flag RepoName   }   deriving (Generic) @@ -2894,6 +2903,7 @@     , uploadPassword = mempty     , uploadPasswordCmd = mempty     , uploadVerbosity = toFlag normal+    , uploadRepoName = mempty     }  uploadCommand :: CommandUI UploadFlags@@ -2978,6 +2988,13 @@                 )                 (flagElim [] (pure . unwords . fmap show))             )+        , option+            ['R']+            ["repository"]+            "Package repository to upload to."+            uploadRepoName+            (\v flags -> flags{uploadRepoName = v})+            (reqArg' "REPOSITORY" (toFlag . RepoName) (flagToList . fmap unRepoName))         ]     } @@ -3003,12 +3020,12 @@         wrapText $           "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n"             ++ "\n"-            ++ "Calling init with no arguments runs interactive mode, "+            ++ "Calling init with no arguments runs interactive mode by default, "             ++ "which will try to guess as much as possible and prompt you for the rest.\n"             ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, "-            ++ "which will let you specify the options via flags and will use the defaults for the rest.\n"-            ++ "It is also possible to call init with a single argument, which denotes the project's desired "-            ++ "root directory.\n"+            ++ "which will let you specify the options via flags and will either use the defaults for the rest, "+            ++ "or attempt to infer sensible defaults from your local development environment (e.g. $PATH).\n"+            ++ "For a basic simple project with minimal prompting and sensible defaults, issue the --simple flag.\n"     , commandNotes = Nothing     , commandUsage = \pname ->         "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n"@@ -3021,7 +3038,10 @@   [ option       ['i']       ["interactive"]-      "interactive mode."+      ( "Interactive mode. Creates a prompt tree for project creation. \n"+          ++ "If -n/--non-interactive is issued, a simple project with inferred defaults \n"+          ++ "is created. If --simple is issued, then sensible defaults will be chosen as well."+      )       IT.interactive       (\v flags -> flags{IT.interactive = v})       (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"]))@@ -3377,7 +3397,8 @@           ++ " v1-copy foo       "           ++ "    A component (i.e. lib, exe, test suite)"     , commandUsage =-        usageAlternatives "v1-copy" $+        usageAlternatives+          "v1-copy"           [ "[FLAGS]"           , "COMPONENTS [FLAGS]"           ]@@ -3477,7 +3498,7 @@ -- ------------------------------------------------------------  data UserConfigFlags = UserConfigFlags-  { userConfigVerbosity :: Flag Verbosity+  { userConfigVerbosity :: Flag VerbosityFlags   , userConfigForce :: Flag Bool   , userConfigAppendLines :: Flag [String]   }
src/Distribution/Client/SetupWrapper.hs view
@@ -1,1171 +1,1503 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{- FOURMOLU_DISABLE -}----------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.SetupWrapper--- Copyright   :  (c) The University of Glasgow 2006,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  alpha--- Portability :  portable------ An interface to building and installing Cabal packages.--- If the @Built-Type@ field is specified as something other than--- 'Custom', and the current version of Cabal is acceptable, this performs--- setup actions directly.  Otherwise it builds the setup script and--- runs it with the given arguments.-module Distribution.Client.SetupWrapper-  ( getSetup-  , runSetup-  , runSetupCommand-  , setupWrapper-  , SetupScriptOptions (..)-  , defaultSetupScriptOptions-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Distribution.Backpack as Backpack-import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)-import qualified Distribution.Make as Make-import Distribution.Package-  ( ComponentId-  , PackageId-  , PackageIdentifier (..)-  , mkPackageName-  , newSimpleUnitId-  , packageName-  , packageVersion-  , unsafeMkDefUnitId-  )-import Distribution.PackageDescription-  ( BuildType (..)-  , GenericPackageDescription (packageDescription)-  , PackageDescription (..)-  , buildType-  , specVersion-  )-import qualified Distribution.Simple as Simple-import Distribution.Simple.Build.Macros-  ( generatePackageVersionMacros-  )-import Distribution.Simple.BuildPaths-  ( defaultDistPref-  , exeExtension-  )-import Distribution.Simple.Compiler-import Distribution.Simple.Configure-  ( configCompilerEx-  )-import Distribution.Simple.PackageDescription-  ( readGenericPackageDescription-  )-import Distribution.Simple.PreProcess-  ( ppUnlit-  , runSimplePreProcessor-  )-import Distribution.Simple.Program-  ( ProgramDb-  , emptyProgramDb-  , getDbProgramOutputCwd-  , getProgramSearchPath-  , ghcProgram-  , ghcjsProgram-  , runDbProgramCwd-  )-import Distribution.Simple.Program.Db-  ( configureAllKnownPrograms-  , prependProgramSearchPath-  , progOverrideEnv-  )-import Distribution.Simple.Program.Find-  ( programSearchPathAsPATHVar-  )-import Distribution.Simple.Program.Run-  ( getEffectiveEnvironment-  )-import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Types.ModuleRenaming (defaultRenaming)-import Distribution.Version-  ( Version-  , VersionRange-  , anyVersion-  , intersectVersionRanges-  , mkVersion-  , orLaterVersion-  , versionNumbers-  , withinRange-  )--import Distribution.Client.Config-  ( defaultCacheDir-  )-import Distribution.Client.IndexUtils-  ( getInstalledPackages-  )-import Distribution.Client.JobControl-  ( Lock-  , criticalSection-  )-import Distribution.Client.Types-import Distribution.Client.Utils-  ( existsAndIsMoreRecentThan-  , makeRelativeToDirS-#ifdef mingw32_HOST_OS-  , canonicalizePathNoThrow-#endif-  , moreRecentFile-  , tryCanonicalizePath-  , withEnv-  , withEnvOverrides-  , withExtraPathEnv-  )-import Distribution.Utils.Path-  hiding ( (</>), (<.>) )-import qualified Distribution.Utils.Path as Cabal.Path-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Simple.Command-  ( CommandUI (..)-  , commandShowOptions-  )-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.Program.GHC-  ( GhcMode (..)-  , GhcOptions (..)-  , renderGhcOptions-  )-import Distribution.Simple.Setup-  ( CommonSetupFlags (..)-  , pattern Flag-  , GlobalFlags (..)-  , globalCommand-  )-import Distribution.Simple.Utils-  ( cabalVersion-  , copyFileVerbose-  , createDirectoryIfMissingVerbose-  , debug-  , die'-  , dieWithException-  , info-  , infoNoWrap-  , installExecutableFile-  , maybeExit-  , rawSystemProc-  , rewriteFileEx-  , rewriteFileLBS-  , tryFindPackageDesc-  )-import Distribution.Utils.Generic-  ( safeHead-  )--import Distribution.Compat.Stack-import Distribution.ReadE-import Distribution.System (Platform (..), buildPlatform)-import Distribution.Utils.NubList-  ( toNubListR-  )-import Distribution.Verbosity--import Data.List (foldl1')-import qualified Data.Map.Lazy as Map-import Distribution.Client.Compat.ExecutablePath (getExecutablePath)-import Distribution.Compat.Process (proc)-import System.Directory (doesFileExist)-import System.FilePath ((<.>), (</>))-import System.IO (Handle, hPutStr)-import System.Process (StdStream (..))-import qualified System.Process as Process--import qualified Data.ByteString.Lazy as BS-import Distribution.Client.Errors--#ifdef mingw32_HOST_OS-import Distribution.Simple.Utils-         ( withTempDirectory )--import Control.Exception   ( bracket )-import System.FilePath     ( equalFilePath, takeDirectory )-import System.Directory    ( doesDirectoryExist )-import qualified System.Win32 as Win32-#endif---- | @Setup@ encapsulates the outcome of configuring a setup method to build a--- particular package.-data Setup = Setup-  { setupMethod :: SetupMethod-  , setupScriptOptions :: SetupScriptOptions-  , setupVersion :: Version-  , setupBuildType :: BuildType-  , setupPackage :: PackageDescription-  }---- | @SetupMethod@ represents one of the methods used to run Cabal commands.-data SetupMethod-  = -- | run Cabal commands through \"cabal\" in the-    -- current process-    InternalMethod-  | -- | run Cabal commands through \"cabal\" as a-    -- child process-    SelfExecMethod-  | -- | run Cabal commands through a custom \"Setup\" executable-    ExternalMethod FilePath---- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two--- parts: one that has no policy and just does as it's told with all the--- explicit options, and an optional initial part that applies certain--- policies (like if we should add the Cabal lib as a dep, and if so which--- version). This could be structured as an action that returns a fully--- elaborated 'SetupScriptOptions' containing no remaining policy choices.------ See also the discussion at https://github.com/haskell/cabal/pull/3094---- | @SetupScriptOptions@ are options used to configure and run 'Setup', as--- opposed to options given to the Cabal command at runtime.-data SetupScriptOptions = SetupScriptOptions-  { useCabalVersion :: VersionRange-  -- ^ The version of the Cabal library to use (if 'useDependenciesExclusive'-  -- is not set). A suitable version of the Cabal library must be installed-  -- (or for some build-types be the one cabal-install was built with).-  ---  -- The version found also determines the version of the Cabal specification-  -- that we us for talking to the Setup.hs, unless overridden by-  -- 'useCabalSpecVersion'.-  , useCabalSpecVersion :: Maybe Version-  -- ^ This is the version of the Cabal specification that we believe that-  -- this package uses. This affects the semantics and in particular the-  -- Setup command line interface.-  ---  -- This is similar to 'useCabalVersion' but instead of probing the system-  -- for a version of the /Cabal library/ you just say exactly which version-  -- of the /spec/ we will use. Using this also avoid adding the Cabal-  -- library as an additional dependency, so add it to 'useDependencies'-  -- if needed.-  , useCompiler :: Maybe Compiler-  , usePlatform :: Maybe Platform-  , usePackageDB :: PackageDBStackCWD-  , usePackageIndex :: Maybe InstalledPackageIndex-  , useProgramDb :: ProgramDb-  , useDistPref :: SymbolicPath Pkg (Dir Dist)-  , useLoggingHandle :: Maybe Handle-  , useWorkingDir :: Maybe (SymbolicPath CWD (Dir Pkg))-  , useExtraPathEnv :: [FilePath]-  -- ^ Extra things to add to PATH when invoking the setup script.-  , useExtraEnvOverrides :: [(String, Maybe FilePath)]-  -- ^ Extra environment variables paired with overrides, where-  ---  -- * @'Just' v@ means \"set the environment variable's value to @v@\".-  -- * 'Nothing' means \"unset the environment variable\".-  , forceExternalSetupMethod :: Bool-  , useDependencies :: [(ComponentId, PackageId)]-  -- ^ List of dependencies to use when building Setup.hs.-  , useDependenciesExclusive :: Bool-  -- ^ Is the list of setup dependencies exclusive?-  ---  -- When this is @False@, if we compile the Setup.hs script we do so with the-  -- list in 'useDependencies' but all other packages in the environment are-  -- also visible. A suitable version of @Cabal@ library (see-  -- 'useCabalVersion') is also added to the list of dependencies, unless-  -- 'useDependencies' already contains a Cabal dependency.-  ---  -- When @True@, only the 'useDependencies' packages are used, with other-  -- packages in the environment hidden.-  ---  -- This feature is here to support the setup stanza in .cabal files that-  -- specifies explicit (and exclusive) dependencies, as well as the old-  -- style with no dependencies.-  , useVersionMacros :: Bool-  -- ^ Should we build the Setup.hs with CPP version macros available?-  -- We turn this on when we have a setup stanza in .cabal that declares-  -- explicit setup dependencies.-  , -- Used only by 'cabal clean' on Windows.-    ---    -- Note: win32 clean hack-    --------------------------    -- On Windows, running './dist/setup/setup clean' doesn't work because the-    -- setup script will try to delete itself (which causes it to fail horribly,-    -- unlike on Linux). So we have to move the setup exe out of the way first-    -- and then delete it manually. This applies only to the external setup-    -- method.-    useWin32CleanHack :: Bool-  , -- Used only when calling setupWrapper from parallel code to serialise-    -- access to the setup cache; should be Nothing otherwise.-    ---    -- Note: setup exe cache-    -------------------------    -- When we are installing in parallel, we always use the external setup-    -- method. Since compiling the setup script each time adds noticeable-    -- overhead, we use a shared setup script cache-    -- ('$XDG_CACHE_HOME/cabal/setup-exe-cache'). For each (compiler, platform, Cabal-    -- version) combination the cache holds a compiled setup script-    -- executable. This only affects the Simple build type; for the Custom,-    -- Configure and Make build types we always compile the setup script anew.-    setupCacheLock :: Maybe Lock-  , isInteractive :: Bool-  -- ^ Is the task we are going to run an interactive foreground task,-  -- or an non-interactive background task? Based on this flag we-  -- decide whether or not to delegate ctrl+c to the spawned task-  , isMainLibOrExeComponent :: Bool-  -- ^ Let the setup script logic know if it is being run to build a main-  -- library or executable component.  This is used to determine if we should-  -- use the configure command, if the build-type is 'Configure'.  For-  -- configure, only the main library and execomponents have 'configure'-  -- support, and thus we can skip running configure for other components.-  }--defaultSetupScriptOptions :: SetupScriptOptions-defaultSetupScriptOptions =-  SetupScriptOptions-    { useCabalVersion = anyVersion-    , useCabalSpecVersion = Nothing-    , useCompiler = Nothing-    , usePlatform = Nothing-    , usePackageDB = [GlobalPackageDB, UserPackageDB]-    , usePackageIndex = Nothing-    , useDependencies = []-    , useDependenciesExclusive = False-    , useVersionMacros = False-    , useProgramDb = emptyProgramDb-    , useDistPref = defaultDistPref-    , useLoggingHandle = Nothing-    , useWorkingDir = Nothing-    , useExtraPathEnv = []-    , useExtraEnvOverrides = []-    , useWin32CleanHack = False-    , forceExternalSetupMethod = False-    , setupCacheLock = Nothing-    , isInteractive = False-    , isMainLibOrExeComponent = True-    }--workingDir :: SetupScriptOptions -> FilePath-workingDir options = case useWorkingDir options of-  Just dir-    | let fp = getSymbolicPath dir-    , not $ null fp-    -> fp-  _ -> "."---- | A @SetupRunner@ implements a 'SetupMethod'.-type SetupRunner =-  Verbosity-  -> SetupScriptOptions-  -> BuildType-  -> [String]-  -> IO ()---- | Prepare to build a package by configuring a 'SetupMethod'. The returned--- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed--- during the configuration process; the final values are given by--- 'setupScriptOptions'.-getSetup-  :: Verbosity-  -> SetupScriptOptions-  -> Maybe PackageDescription-  -> IO Setup-getSetup verbosity options mpkg = do-  pkg <- maybe getPkg return mpkg-  let options' =-        options-          { useCabalVersion =-              intersectVersionRanges-                (useCabalVersion options)-                (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))-          }-      -- We retain Configure only for the main library and executable components.-      -- For other components, we rewrite the buildType to Simple to skip the-      -- configure step.  This is because the configure step is not supported for-      -- other components.  Configure can only impact MainLib and Exe through-      -- .buildinfo files.-      buildType' = case (buildType pkg, isMainLibOrExeComponent options) of-        (Configure, False) -> Simple-        (bt, _) -> bt-  (version, method, options'') <--    getSetupMethod verbosity options' pkg buildType'-  return-    Setup-      { setupMethod = method-      , setupScriptOptions = options''-      , setupVersion = version-      , setupBuildType = buildType'-      , setupPackage = pkg-      }-  where-    mbWorkDir = useWorkingDir options-    getPkg =-      (relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir)-        >>= readGenericPackageDescription verbosity mbWorkDir-        >>= return . packageDescription---- | Decide if we're going to be able to do a direct internal call to the--- entry point in the Cabal library or if we're going to have to compile--- and execute an external Setup.hs script.-getSetupMethod-  :: Verbosity-  -> SetupScriptOptions-  -> PackageDescription-  -> BuildType-  -> IO (Version, SetupMethod, SetupScriptOptions)-getSetupMethod verbosity options pkg buildType'-  | buildType' == Custom-      || buildType' == Hooks-      || maybe False (cabalVersion /=) (useCabalSpecVersion options)-      || not (cabalVersion `withinRange` useCabalVersion options) =-      getExternalSetupMethod verbosity options pkg buildType'-  | isJust (useLoggingHandle options)-      -- Forcing is done to use an external process e.g. due to parallel-      -- build concerns.-      || forceExternalSetupMethod options =-      return (cabalVersion, SelfExecMethod, options)-  | otherwise = return (cabalVersion, InternalMethod, options)--runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)-runSetupMethod InternalMethod = internalSetupMethod-runSetupMethod (ExternalMethod path) = externalSetupMethod path-runSetupMethod SelfExecMethod = selfExecSetupMethod---- | Run a configured 'Setup' with specific arguments.-runSetup-  :: Verbosity-  -> Setup-  -> [String]-  -- ^ command-line arguments-  -> IO ()-runSetup verbosity setup args0 = do-  let method = setupMethod setup-      options = setupScriptOptions setup-      bt = setupBuildType setup-      args = verbosityHack (setupVersion setup) args0-  when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $-    infoNoWrap verbose $-      "Applied verbosity hack:\n"-        ++ "  Before: "-        ++ show args0-        ++ "\n"-        ++ "  After:  "-        ++ show args-        ++ "\n"-  runSetupMethod method verbosity options bt args---- | This is a horrible hack to make sure passing fancy verbosity--- flags (e.g., @-v'info +callstack'@) doesn't break horribly on--- old Setup.  We can't do it in 'filterConfigureFlags' because--- verbosity applies to ALL commands.-verbosityHack :: Version -> [String] -> [String]-verbosityHack ver args0-  | ver >= mkVersion [2, 1] = args0-  | otherwise = go args0-  where-    go (('-' : 'v' : rest) : args)-      | Just rest' <- munch rest = ("-v" ++ rest') : go args-    go (('-' : '-' : 'v' : 'e' : 'r' : 'b' : 'o' : 's' : 'e' : '=' : rest) : args)-      | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args-    go ("--verbose" : rest : args)-      | Just rest' <- munch rest = "--verbose" : rest' : go args-    go rest@("--" : _) = rest-    go (arg : args) = arg : go args-    go [] = []--    munch rest =-      case runReadE flagToVerbosity rest of-        Right v-          | ver < mkVersion [2, 0]-          , verboseHasFlags v ->-              -- We could preserve the prefix, but since we're assuming-              -- it's Cabal's verbosity flag, we can assume that-              -- any format is OK-              Just (showForCabal (verboseNoFlags v))-          | ver < mkVersion [2, 1]-          , isVerboseTimestamp v ->-              -- +timestamp wasn't yet available in Cabal-2.0.0-              Just (showForCabal (verboseNoTimestamp v))-        _ -> Nothing---- | Run a command through a configured 'Setup'.-runSetupCommand-  :: Verbosity-  -> Setup-  -> CommandUI flags-  -- ^ command definition-  -> (flags -> CommonSetupFlags)-  -> flags-  -- ^ command flags-  -> [String]-  -- ^ extra command-line arguments-  -> IO ()-runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs =-  -- The 'setupWorkingDir' flag corresponds to a global argument which needs to-  -- be passed before the individual command (e.g. 'configure' or 'build').-  let common = getCommonFlags flags-      globalFlags = mempty { globalWorkingDir = setupWorkingDir common }-      args = commandShowOptions (globalCommand []) globalFlags-          ++ (commandName cmd : commandShowOptions cmd flags ++ extraArgs)-  in runSetup verbosity setup args---- | Configure a 'Setup' and run a command in one step. The command flags--- may depend on the Cabal library version in use.-setupWrapper-  :: Verbosity-  -> SetupScriptOptions-  -> Maybe PackageDescription-  -> CommandUI flags-  -> (flags -> CommonSetupFlags)-  -> (Version -> IO flags)-  -- ^ produce command flags given the Cabal library version-  -> (Version -> [String])-  -> IO ()-setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs = do-  setup <- getSetup verbosity options mpkg-  let version = setupVersion setup-      extraArgs = getExtraArgs version-  flags <- getFlags version-  runSetupCommand-    verbosity-    setup-    cmd-    getCommonFlags-    flags-    extraArgs---- ---------------------------------------------------------------- * Internal SetupMethod---- ---------------------------------------------------------------- | Run a Setup script by directly invoking the @Cabal@ library.-internalSetupMethod :: SetupRunner-internalSetupMethod verbosity options bt args = do-  info verbosity $-    "Using internal setup method with build-type "-      ++ show bt-      ++ " and args:\n  "-      ++ show args-  -- NB: we do not set the working directory of the process here, because-  -- we will instead pass the -working-dir flag when invoking the Setup script.-  -- Note that the Setup script is guaranteed to support this flag, because-  -- the logic in 'getSetupMethod' guarantees we have an up-to-date Cabal version.-  ---  -- In the future, it would be desirable to also stop relying on the following-  -- pieces of process-global state, as this would allow us to use this internal-  -- setup method in concurrent contexts.-  withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $-    withExtraPathEnv (useExtraPathEnv options) $-      withEnvOverrides (useExtraEnvOverrides options) $-        buildTypeAction bt args--buildTypeAction :: BuildType -> ([String] -> IO ())-buildTypeAction Simple = Simple.defaultMainArgs-buildTypeAction Configure =-  Simple.defaultMainWithSetupHooksArgs-    Simple.autoconfSetupHooks-buildTypeAction Make = Make.defaultMainArgs-buildTypeAction Hooks  = error "buildTypeAction Hooks"-buildTypeAction Custom = error "buildTypeAction Custom"--invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO ()-invoke verbosity path args options = do-  info verbosity $ unwords (path : args)-  case useLoggingHandle options of-    Nothing -> return ()-    Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle--  progDb <- prependProgramSearchPath verbosity (useExtraPathEnv options) (useExtraEnvOverrides options) (useProgramDb options)--  searchpath <--    programSearchPathAsPATHVar $ getProgramSearchPath progDb--  env <--    getEffectiveEnvironment $-      [ ("PATH", Just searchpath)-      , ("HASKELL_DIST_DIR", Just (getSymbolicPath $ useDistPref options))-      ]-        ++ progOverrideEnv progDb--  let loggingHandle = case useLoggingHandle options of-        Nothing -> Inherit-        Just hdl -> UseHandle hdl-      cp =-        (proc path args)-          { Process.cwd = fmap getSymbolicPath $ useWorkingDir options-          , Process.env = env-          , Process.std_out = loggingHandle-          , Process.std_err = loggingHandle-          , Process.delegate_ctlc = isInteractive options-          }-  maybeExit $ rawSystemProc verbosity cp---- ---------------------------------------------------------------- * Self-Exec SetupMethod---- --------------------------------------------------------------selfExecSetupMethod :: SetupRunner-selfExecSetupMethod verbosity options bt args0 = do-  let args =-        [ "act-as-setup"-        , "--build-type=" ++ prettyShow bt-        , "--"-        ]-          ++ args0-  info verbosity $-    "Using self-exec internal setup method with build-type "-      ++ show bt-      ++ " and args:\n  "-      ++ show args-  path <- getExecutablePath-  invoke verbosity path args options---- ---------------------------------------------------------------- * External SetupMethod---- --------------------------------------------------------------externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)-externalSetupMethod path verbosity options _ args =-#ifndef mingw32_HOST_OS-  invoke-    verbosity-    path-    args-    options-#else-    -- See 'Note: win32 clean hack' above.-    if useWin32CleanHack options-      then invokeWithWin32CleanHack path-      else invoke' path-  where-    invoke' p = invoke verbosity p args options--    invokeWithWin32CleanHack origPath = do-      info verbosity $ "Using the Win32 clean hack."-      -- Recursively removes the temp dir on exit.-      withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->-        bracket-          (moveOutOfTheWay tmpDir origPath)-          (\tmpPath -> maybeRestore origPath tmpPath)-          (\tmpPath -> invoke' tmpPath)--    moveOutOfTheWay tmpDir origPath = do-      let tmpPath = tmpDir </> "setup" <.> exeExtension buildPlatform-      Win32.moveFile origPath tmpPath-      return tmpPath--    maybeRestore origPath tmpPath = do-      let origPathDir = takeDirectory origPath-      origPathDirExists <- doesDirectoryExist origPathDir-      -- 'setup clean' didn't complete, 'dist/setup' still exists.-      when origPathDirExists $-        Win32.moveFile tmpPath origPath--#endif--getExternalSetupMethod-  :: Verbosity-  -> SetupScriptOptions-  -> PackageDescription-  -> BuildType-  -> IO (Version, SetupMethod, SetupScriptOptions)-getExternalSetupMethod verbosity options pkg bt = do-  debug verbosity $ "Using external setup method with build-type " ++ show bt-  debug verbosity $-    "Using explicit dependencies: "-      ++ show (useDependenciesExclusive options)-  createDirectoryIfMissingVerbose verbosity True $ i setupDir-  (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse-  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion-  path <--    if useCachedSetupExecutable-      then-        getCachedSetupExecutable-          options'-          cabalLibVersion-          mCabalLibInstalledPkgId-      else-        compileSetupExecutable-          options'-          cabalLibVersion-          mCabalLibInstalledPkgId-          False--  -- Since useWorkingDir can change the relative path, the path argument must-  -- be turned into an absolute path. On some systems, runProcess' will take-  -- path as relative to the new working directory instead of the current-  -- working directory.-  path' <- tryCanonicalizePath path--  -- See 'Note: win32 clean hack' above.-#ifdef mingw32_HOST_OS-  -- setupProgFile may not exist if we're using a cached program-  setupProgFile' <- canonicalizePathNoThrow $ i setupProgFile-  let win32CleanHackNeeded =-        (useWin32CleanHack options)-          -- Skip when a cached setup script is used.-          && setupProgFile' `equalFilePath` path'-#else-  let win32CleanHackNeeded = False-#endif-  let options'' = options'{useWin32CleanHack = win32CleanHackNeeded}--  return (cabalLibVersion, ExternalMethod path', options'')-  where-    mbWorkDir = useWorkingDir options-    -- See Note [Symbolic paths] in Distribution.Utils.Path-    i = interpretSymbolicPath mbWorkDir-    setupDir = useDistPref options Cabal.Path.</> makeRelativePathEx "setup"-    setupVersionFile = setupDir Cabal.Path.</> makeRelativePathEx ("setup" <.> "version")-    setupHs = setupDir Cabal.Path.</> makeRelativePathEx ("setup" <.> "hs")-    setupHooks = setupDir Cabal.Path.</> makeRelativePathEx ("SetupHooks" <.> "hs")-    setupProgFile = setupDir Cabal.Path.</> makeRelativePathEx ("setup" <.> exeExtension buildPlatform)--    platform = fromMaybe buildPlatform (usePlatform options)--    useCachedSetupExecutable =-      bt == Simple || bt == Configure || bt == Make--    maybeGetInstalledPackages-      :: SetupScriptOptions-      -> Compiler-      -> ProgramDb-      -> IO InstalledPackageIndex-    maybeGetInstalledPackages options' comp progdb =-      case usePackageIndex options' of-        Just index -> return index-        Nothing ->-          getInstalledPackages-            verbosity-            comp-            (usePackageDB options')-            progdb--    -- Choose the version of Cabal to use if the setup script has a dependency on-    -- Cabal, and possibly update the setup script options. The version also-    -- determines how to filter the flags to Setup.-    ---    -- We first check whether the dependency solver has specified a Cabal version.-    -- If it has, we use the solver's version without looking at the installed-    -- package index (See issue #3436). Otherwise, we pick the Cabal version by-    -- checking 'useCabalSpecVersion', then the saved version, and finally the-    -- versions available in the index.-    ---    -- The version chosen here must match the one used in 'compileSetupExecutable'-    -- (See issue #3433).-    cabalLibVersionToUse-      :: IO-          ( Version-          , Maybe ComponentId-          , SetupScriptOptions-          )-    cabalLibVersionToUse =-      case find (isCabalPkgId . snd) (useDependencies options) of-        Just (unitId, pkgId) -> do-          let version = pkgVersion pkgId-          updateSetupScript version bt-          writeSetupVersionFile version-          return (version, Just unitId, options)-        Nothing ->-          case useCabalSpecVersion options of-            Just version -> do-              updateSetupScript version bt-              writeSetupVersionFile version-              return (version, Nothing, options)-            Nothing -> do-              savedVer <- savedVersion-              case savedVer of-                Just version | version `withinRange` useCabalVersion options ->-                  do-                    updateSetupScript version bt-                    -- Does the previously compiled setup executable-                    -- still exist and is it up-to date?-                    useExisting <- canUseExistingSetup version-                    if useExisting-                      then return (version, Nothing, options)-                      else installedVersion-                _ -> installedVersion-      where-        -- This check duplicates the checks in 'getCachedSetupExecutable' /-        -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice-        -- because the selected Cabal version may change as a result of this-        -- check.-        canUseExistingSetup :: Version -> IO Bool-        canUseExistingSetup version =-          if useCachedSetupExecutable-            then do-              (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version-              doesFileExist cachedSetupProgFile-            else-              (&&)-                <$> i setupProgFile `existsAndIsMoreRecentThan` i setupHs-                <*> i setupProgFile `existsAndIsMoreRecentThan` i setupVersionFile--        writeSetupVersionFile :: Version -> IO ()-        writeSetupVersionFile version =-          writeFile (i setupVersionFile) (show version ++ "\n")--        installedVersion-          :: IO-              ( Version-              , Maybe InstalledPackageId-              , SetupScriptOptions-              )-        installedVersion = do-          (comp, progdb, options') <- configureCompiler options-          (version, mipkgid, options'') <--            installedCabalVersion-              options'-              comp-              progdb-          updateSetupScript version bt-          writeSetupVersionFile version-          return (version, mipkgid, options'')--        savedVersion :: IO (Maybe Version)-        savedVersion = do-          versionString <- readFile (i setupVersionFile) `catchIO` \_ -> return ""-          case reads versionString of-            [(version, s)] | all isSpace s -> return (Just version)-            _ -> return Nothing--    -- \| Update a Setup.hs script, creating it if necessary.-    updateSetupScript :: Version -> BuildType -> IO ()-    updateSetupScript _ Custom = do-      useHs <- doesFileExist customSetupHs-      useLhs <- doesFileExist customSetupLhs-      unless (useHs || useLhs) $-        dieWithException verbosity UpdateSetupScript-      let src = (if useHs then customSetupHs else customSetupLhs)-      srcNewer <- src `moreRecentFile` i setupHs-      when srcNewer $-        if useHs-          then copyFileVerbose verbosity src (i setupHs)-          else runSimplePreProcessor ppUnlit src (i setupHs) verbosity-      where-        customSetupHs = workingDir options </> "Setup.hs"-        customSetupLhs = workingDir options </> "Setup.lhs"-    updateSetupScript cabalLibVersion Hooks = do--      let customSetupHooks = workingDir options </> "SetupHooks.hs"-      useHs <- doesFileExist customSetupHooks-      unless (useHs) $-        die'-          verbosity-          "Using 'build-type: Hooks' but there is no SetupHooks.hs file."-      copyFileVerbose verbosity customSetupHooks (i setupHooks)-      rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion)---      rewriteFileLBS verbosity hooksHs hooksScript-    updateSetupScript cabalLibVersion _ =-      rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion)--    buildTypeScript :: Version -> BS.ByteString-    buildTypeScript cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of-      Simple -> "import Distribution.Simple; main = defaultMain\n"-      Configure-        | cabalLibVersion >= mkVersion [3, 13, 0]-        -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n"-        | cabalLibVersion >= mkVersion [1, 3, 10]-        -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"-        | otherwise-        -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"-      Make -> "import Distribution.Make; main = defaultMain\n"-      Hooks-        | cabalLibVersion >= mkVersion [3, 13, 0]-        -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n"-        | otherwise-        -> error "buildTypeScript Hooks with Cabal < 3.13"-      Custom -> error "buildTypeScript Custom"--    installedCabalVersion-      :: SetupScriptOptions-      -> Compiler-      -> ProgramDb-      -> IO-          ( Version-          , Maybe InstalledPackageId-          , SetupScriptOptions-          )-    installedCabalVersion options' _ _-      | packageName pkg == mkPackageName "Cabal"-          && bt == Custom =-          return (packageVersion pkg, Nothing, options')-    installedCabalVersion options' compiler progdb = do-      index <- maybeGetInstalledPackages options' compiler progdb-      let cabalDepName = mkPackageName "Cabal"-          cabalDepVersion = useCabalVersion options'-          options'' = options'{usePackageIndex = Just index}-      case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of-        [] ->-          dieWithException verbosity $ InstalledCabalVersion (packageName pkg) (useCabalVersion options)-        pkgs ->-          let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs-              err = error "Distribution.Client.installedCabalVersion: empty version list"-           in return-                ( packageVersion ipkginfo-                , Just . IPI.installedComponentId $ ipkginfo-                , options''-                )--    bestVersion :: (a -> Version) -> [a] -> a-    bestVersion f = firstMaximumBy (comparing (preference . f))-      where-        -- Like maximumBy, but picks the first maximum element instead of the-        -- last. In general, we expect the preferred version to go first in the-        -- list. For the default case, this has the effect of choosing the version-        -- installed in the user package DB instead of the global one. See #1463.-        ---        -- Note: firstMaximumBy could be written as just-        -- `maximumBy cmp . reverse`, but the problem is that the behaviour of-        -- maximumBy is not fully specified in the case when there is not a single-        -- greatest element.-        firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a-        firstMaximumBy _ [] =-          error "Distribution.Client.firstMaximumBy: empty list"-        firstMaximumBy cmp xs = foldl1' maxBy xs-          where-            maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y--        preference version =-          ( sameVersion-          , sameMajorVersion-          , stableVersion-          , latestVersion-          )-          where-            sameVersion = version == cabalVersion-            sameMajorVersion = majorVersion version == majorVersion cabalVersion-            majorVersion = take 2 . versionNumbers-            stableVersion = case versionNumbers version of-              (_ : x : _) -> even x-              _ -> False-            latestVersion = version--    configureCompiler-      :: SetupScriptOptions-      -> IO (Compiler, ProgramDb, SetupScriptOptions)-    configureCompiler options' = do-      (comp, progdb) <- case useCompiler options' of-        Just comp -> return (comp, useProgramDb options')-        Nothing -> do-          (comp, _, progdb) <--            configCompilerEx-              (Just GHC)-              Nothing-              Nothing-              (useProgramDb options')-              verbosity-          return (comp, progdb)-      -- Whenever we need to call configureCompiler, we also need to access the-      -- package index, so let's cache it in SetupScriptOptions.-      index <- maybeGetInstalledPackages options' comp progdb-      return-        ( comp-        , progdb-        , options'-            { useCompiler = Just comp-            , usePackageIndex = Just index-            , useProgramDb = progdb-            }-        )--    -- \| Path to the setup exe cache directory and path to the cached setup-    -- executable.-    cachedSetupDirAndProg-      :: SetupScriptOptions-      -> Version-      -> IO (FilePath, FilePath)-    cachedSetupDirAndProg options' cabalLibVersion = do-      cacheDir <- defaultCacheDir-      let setupCacheDir = cacheDir </> "setup-exe-cache"-          cachedSetupProgFile =-            setupCacheDir-              </> ( "setup-"-                      ++ buildTypeString-                      ++ "-"-                      ++ cabalVersionString-                      ++ "-"-                      ++ platformString-                      ++ "-"-                      ++ compilerVersionString-                  )-              <.> exeExtension buildPlatform-      return (setupCacheDir, cachedSetupProgFile)-      where-        buildTypeString = show bt-        cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion-        compilerVersionString =-          prettyShow $-            maybe buildCompilerId compilerId $-              useCompiler options'-        platformString = prettyShow platform--    -- \| Look up the setup executable in the cache; update the cache if the setup-    -- executable is not found.-    getCachedSetupExecutable-      :: SetupScriptOptions-      -> Version-      -> Maybe InstalledPackageId-      -> IO FilePath-    getCachedSetupExecutable-      options'-      cabalLibVersion-      maybeCabalLibInstalledPkgId = do-        (setupCacheDir, cachedSetupProgFile) <--          cachedSetupDirAndProg options' cabalLibVersion-        cachedSetupExists <- doesFileExist cachedSetupProgFile-        if cachedSetupExists-          then-            debug verbosity $-              "Found cached setup executable: " ++ cachedSetupProgFile-          else criticalSection' $ do-            -- The cache may have been populated while we were waiting.-            cachedSetupExists' <- doesFileExist cachedSetupProgFile-            if cachedSetupExists'-              then-                debug verbosity $-                  "Found cached setup executable: " ++ cachedSetupProgFile-              else do-                debug verbosity $ "Setup executable not found in the cache."-                src <--                  compileSetupExecutable-                    options'-                    cabalLibVersion-                    maybeCabalLibInstalledPkgId-                    True-                createDirectoryIfMissingVerbose verbosity True setupCacheDir-                installExecutableFile verbosity src cachedSetupProgFile-                -- Do not strip if we're using GHCJS, since the result may be a script-                when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do-                  -- Add the relevant PATH overrides for the package to the-                  -- program database.-                  setupProgDb-                    <- prependProgramSearchPath verbosity-                          (useExtraPathEnv options)-                          (useExtraEnvOverrides options)-                          (useProgramDb options')-                         >>= configureAllKnownPrograms verbosity-                  Strip.stripExe-                    verbosity-                    platform-                    setupProgDb-                    cachedSetupProgFile-        return cachedSetupProgFile-        where-          criticalSection' = maybe id criticalSection $ setupCacheLock options'--    -- \| If the Setup.hs is out of date wrt the executable then recompile it.-    -- Currently this is GHC/GHCJS only. It should really be generalised.-    compileSetupExecutable-      :: SetupScriptOptions-      -> Version-      -> Maybe ComponentId-      -> Bool-      -> IO FilePath-    compileSetupExecutable-      options'-      cabalLibVersion-      maybeCabalLibInstalledPkgId-      forceCompile = do-        setupHsNewer <- i setupHs `moreRecentFile` i setupProgFile-        cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile-        let outOfDate = setupHsNewer || cabalVersionNewer-        when (outOfDate || forceCompile) $ do-          debug verbosity "Setup executable needs to be updated, compiling..."-          (compiler, progdb, options'') <- configureCompiler options'-          pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options''))-          let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion-              (program, extraOpts) =-                case compilerFlavor compiler of-                  GHCJS -> (ghcjsProgram, ["-build-runner"])-                  _ -> (ghcProgram, ["-threaded"])-              cabalDep =-                maybe-                  []-                  (\ipkgid -> [(ipkgid, cabalPkgid)])-                  maybeCabalLibInstalledPkgId--              -- With 'useDependenciesExclusive' and Custom build type,-              -- we enforce the deps specified, so only the given ones can be used.-              -- Otherwise we add on a dep on the Cabal library-              -- (unless 'useDependencies' already contains one).-              selectedDeps-                |  (useDependenciesExclusive options' && (bt /= Hooks))-                -- NB: to compile build-type: Hooks packages, we need Cabal-                -- in order to compile @main = defaultMainWithSetupHooks setupHooks@.-                || any (isCabalPkgId . snd) (useDependencies options')-                = useDependencies options'-                | otherwise =-                    useDependencies options' ++ cabalDep-              addRenaming (ipid, _) =-                -- Assert 'DefUnitId' invariant-                ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))-                , defaultRenaming-                )-              cppMacrosFile = setupDir Cabal.Path.</> makeRelativePathEx "setup_macros.h"-              ghcOptions =-                mempty-                  { -- Respect -v0, but don't crank up verbosity on GHC if-                    -- Cabal verbosity is requested. For that, use-                    -- --ghc-option=-v instead!-                    ghcOptVerbosity = Flag (min verbosity normal)-                  , ghcOptMode = Flag GhcModeMake-                  , ghcOptInputFiles = toNubListR [setupHs]-                  , ghcOptOutputFile = Flag $ setupProgFile-                  , ghcOptObjDir = Flag $ setupDir-                  , ghcOptHiDir = Flag $ setupDir-                  , ghcOptSourcePathClear = Flag True-                  , ghcOptSourcePath = case bt of-                      Custom -> toNubListR [sameDirectory]-                      Hooks -> toNubListR [sameDirectory]-                      _ -> mempty-                  , ghcOptPackageDBs = pkgDbs-                  , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')-                  , ghcOptCabal = Flag (useDependenciesExclusive options')-                  , ghcOptPackages = toNubListR $ map addRenaming selectedDeps-                  -- With 'useVersionMacros', use a version CPP macros .h file.-                  , ghcOptCppIncludes =-                      toNubListR-                        [ cppMacrosFile-                        | useVersionMacros options'-                        ]-                  , ghcOptExtra = extraOpts-                  , ghcOptExtensions = toNubListR $-                      if bt == Custom || any (isBasePkgId . snd) selectedDeps-                      then []-                      else [ Simple.DisableExtension Simple.ImplicitPrelude ]-                        -- Pass -WNoImplicitPrelude to avoid depending on base-                        -- when compiling a Simple Setup.hs file.-                  , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler-                  }-          let ghcCmdLine = renderGhcOptions compiler platform ghcOptions-          when (useVersionMacros options') $-            rewriteFileEx verbosity (i cppMacrosFile) $-              generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)-          case useLoggingHandle options of-            Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine-            -- If build logging is enabled, redirect compiler output to-            -- the log file.-            Just logHandle -> do-              output <--                getDbProgramOutputCwd-                  verbosity-                  mbWorkDir-                  program-                  progdb-                  ghcCmdLine-              hPutStr logHandle output-        return $ i setupProgFile--isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool-isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"-isBasePkgId (PackageIdentifier pname _) = pname == mkPackageName "base"+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{- FOURMOLU_DISABLE -}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Client.SetupWrapper+-- Copyright   :  (c) The University of Glasgow 2006,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  alpha+-- Portability :  portable+--+-- An interface to building and installing Cabal packages.+-- If the @Built-Type@ field is specified as something other than+-- 'Custom', and the current version of Cabal is acceptable, this performs+-- setup actions directly.  Otherwise it builds the setup script and+-- runs it with the given arguments.+module Distribution.Client.SetupWrapper+  ( SetupRunnerArgs(..)+  , SPostConfigurePhase(..)+  , InLibraryArgs(..)+  , SetupRunnerRes+  , InLibraryLBI(..)+  , RightFlagsForPhase+  , setupWrapper+  , SetupScriptOptions (..)+  , defaultSetupScriptOptions+  , externalSetupMethod+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Backpack as Backpack+import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)+import Distribution.Package+  ( ComponentId+  , PackageId+  , PackageIdentifier (..)+  , mkPackageName+  , newSimpleUnitId+  , packageName+  , packageVersion+  , unsafeMkDefUnitId+  )+import Distribution.PackageDescription+  ( BuildType (..)+  , GenericPackageDescription (packageDescription)+  , PackageDescription (..)+  , buildType+  , specVersion+  )+import qualified Distribution.Simple as Simple+import Distribution.Simple.Build.Macros+  ( generatePackageVersionMacros+  )+import Distribution.Simple.BuildPaths+  ( exeExtension+  )+import Distribution.Simple.Compiler+import Distribution.Simple.Configure+  hiding ( getInstalledPackages )+import Distribution.Simple.PackageDescription+  ( readGenericPackageDescription+  )+import Distribution.Simple.PreProcess+  ( ppUnlit+  , runSimplePreProcessor+  )+import Distribution.Simple.Program+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+  ( programSearchPathAsPATHVar+  )+import Distribution.Simple.Program.Run+  ( getEffectiveEnvironment+  )+import qualified Distribution.Simple.Program.Strip as Strip+import Distribution.Types.ModuleRenaming (defaultRenaming)+import Distribution.Version+  ( Version+  , VersionRange+  , anyVersion+  , intersectVersionRanges+  , mkVersion+  , orLaterVersion+  , versionNumbers+  , withinRange+  )++import Distribution.Client.Config+  ( defaultCacheDir+  )+import Distribution.Client.FileMonitor+  ( MonitorFilePath )+import Distribution.Client.IndexUtils+  ( getInstalledPackages+  )+import Distribution.Client.JobControl+  ( Lock+  , criticalSection+  )+import Distribution.Client.Types+import Distribution.Client.Utils+  ( existsAndIsMoreRecentThan+  , makeRelativeToDirS+#ifdef mingw32_HOST_OS+  , canonicalizePathNoThrow+#endif+  , moreRecentFile+  , tryCanonicalizePath+  )+import Distribution.Utils.Path+  hiding ( (</>), (<.>) )+import qualified Distribution.Utils.Path as Cabal.Path+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Simple.Command+  ( CommandUI (..)+  , commandShowOptions+  )+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.Program.GHC+  ( GhcMode (..)+  , GhcOptions (..)+  , renderGhcOptions+  )+import Distribution.Simple.Utils+  ( cabalVersion+  , copyFileVerbose+  , createDirectoryIfMissingVerbose+  , debug+  , die'+  , dieWithException+  , info+  , infoNoWrap+  , installExecutableFile+  , maybeExit+  , rawSystemProc+  , rewriteFileEx+  , rewriteFileLBS+  , tryFindPackageDesc+  )+import Distribution.Utils.Generic+  ( safeHead+  )++import Distribution.Compat.Stack+import Distribution.ReadE+import Distribution.Simple.Setup+import Distribution.Compat.Process (proc)+import Distribution.System (Platform (..), buildPlatform)+import Distribution.Utils.NubList+  ( toNubListR+  )+import Distribution.Types.LocalBuildInfo ( LocalBuildInfo )+import qualified Distribution.Types.LocalBuildInfo as LBI+import Distribution.Verbosity+import Distribution.Client.Errors+import qualified Distribution.Client.InLibrary as InLibrary+import Distribution.Client.ProjectPlanning.Types+import Distribution.Simple.SetupHooks.HooksMain+  ( hooksVersion )+import Distribution.Client.SetupHooks.CallHooksExe+  ( externalSetupHooksABI, hooksProgFilePath )++import Control.Concurrent.STM (TVar, readTVarIO)+import qualified Data.ByteString.Lazy as BS+import Data.List (foldl1')+import Data.Kind (Type, Constraint)+import qualified Data.Map.Lazy as Map+import Data.Type.Equality  ( type (==) )+import Data.Type.Bool      ( If )+import System.Directory (doesFileExist)+import System.FilePath ((<.>), (</>))+import Data.Functor ((<&>))+import System.IO (Handle, hPutStr)+import System.Process (StdStream (..))+import qualified System.Process as Process++#ifdef mingw32_HOST_OS+import Distribution.Simple.Utils+         ( withTempDirectory )++import Control.Exception   ( bracket )+import System.Directory    ( doesDirectoryExist )+import System.FilePath     ( equalFilePath, takeDirectory, takeFileName )+import qualified System.Win32 as Win32+#endif++--------------------------------------------------------------------------------++data AllowInLibrary+  = AllowInLibrary+  | Don'tAllowInLibrary+  deriving Eq++data SetupKind+  = InLibrary+  | GeneralSetup++-- | If we end up using the in-library method, we use the v'InLibraryLBI'+-- constructor. If not, we use the 'NotInLibraryNoLBI' constructor.+--+-- NB: we don't know ahead of time whether we can use the in-library method;+-- e.g. for a package with Hooks build-type, it depends on whether the Cabal+-- version used by the package matches with the Cabal version that cabal-install+-- was built against.+data InLibraryLBI+  = InLibraryLBI LocalBuildInfo+  | NotInLibraryNoLBI++data SPostConfigurePhase (flags :: Type) where+  SBuildPhase    :: SPostConfigurePhase BuildFlags+  SHaddockPhase  :: SPostConfigurePhase HaddockFlags+  SReplPhase     :: SPostConfigurePhase ReplFlags+  SCopyPhase     :: SPostConfigurePhase CopyFlags+  SRegisterPhase :: SPostConfigurePhase RegisterFlags+  STestPhase     :: SPostConfigurePhase TestFlags+  SBenchPhase    :: SPostConfigurePhase BenchmarkFlags++data SetupWrapperSpec+  = TryInLibrary Type+  | UseGeneralSetup++type family RightFlagsForPhase (flags :: Type) (setupSpec :: SetupWrapperSpec) :: Constraint where+  RightFlagsForPhase flags UseGeneralSetup = ()+  RightFlagsForPhase flags (TryInLibrary flags') = flags ~ flags'++data SetupRunnerArgs (spec :: SetupWrapperSpec) where+  NotInLibrary+    :: SetupRunnerArgs UseGeneralSetup+  InLibraryArgs+    :: InLibraryArgs flags+    -> SetupRunnerArgs (TryInLibrary flags)++data InLibraryArgs (flags :: Type) where+  InLibraryConfigureArgs+    :: ElaboratedSharedConfig+    -> ElaboratedReadyPackage+    -> TVar InstalledPackageIndex+    -> InLibraryArgs ConfigFlags+  InLibraryPostConfigureArgs+    :: SPostConfigurePhase flags+    -> InLibraryLBI+    -> InLibraryArgs flags++type family SetupRunnerRes (spec :: SetupWrapperSpec) where+  SetupRunnerRes UseGeneralSetup = ()+  SetupRunnerRes (TryInLibrary phase) = InLibraryPhaseRes phase++type family InLibraryPhaseRes flags where+  InLibraryPhaseRes ConfigFlags  = InLibraryLBI+  InLibraryPhaseRes BuildFlags   = [MonitorFilePath]+  InLibraryPhaseRes HaddockFlags = [MonitorFilePath]+  InLibraryPhaseRes ReplFlags    = [MonitorFilePath]+  InLibraryPhaseRes _            = ()++-- | @Setup@ encapsulates the outcome of configuring a setup method to build a+-- particular package.+data Setup kind = Setup+  { setupMethod :: SetupMethod kind+  , setupScriptOptions :: SetupScriptOptions+  , setupVersion :: Version+  , setupBuildType :: BuildType+  , setupPackage :: PackageDescription+  }++data ASetup = forall kind. ASetup ( Setup kind )++-- | @SetupMethod@ represents one of the methods used to run Cabal commands.+data SetupMethod (kind :: SetupKind) where+  -- | Directly use Cabal library functions, bypassing the Setup+  -- mechanism entirely.+    LibraryMethod :: SetupMethod InLibrary+  -- | run Cabal commands through a custom \"Setup\" executable+    ExternalMethod :: FilePath -> SetupMethod GeneralSetup++-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two+-- parts: one that has no policy and just does as it's told with all the+-- explicit options, and an optional initial part that applies certain+-- policies (like if we should add the Cabal lib as a dep, and if so which+-- version). This could be structured as an action that returns a fully+-- elaborated 'SetupScriptOptions' containing no remaining policy choices.+--+-- See also the discussion at https://github.com/haskell/cabal/pull/3094++-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as+-- opposed to options given to the Cabal command at runtime.+data SetupScriptOptions = SetupScriptOptions+  { useCabalVersion :: VersionRange+  -- ^ The version of the Cabal library to use (if 'useDependenciesExclusive'+  -- is not set). A suitable version of the Cabal library must be installed+  -- (or for some build-types be the one cabal-install was built with).+  --+  -- The version found also determines the version of the Cabal specification+  -- that we us for talking to the Setup.hs, unless overridden by+  -- 'useCabalSpecVersion'.+  , useCabalSpecVersion :: Maybe Version+  -- ^ This is the version of the Cabal specification that we believe that+  -- this package uses. This affects the semantics and in particular the+  -- Setup command line interface.+  --+  -- This is similar to 'useCabalVersion' but instead of probing the system+  -- for a version of the /Cabal library/ you just say exactly which version+  -- of the /spec/ we will use. Using this also avoids adding the Cabal+  -- library as an additional dependency, so add it to 'useDependencies'+  -- if needed.+  , useCompiler :: Maybe Compiler+  , usePlatform :: Maybe Platform+  , usePackageDB :: PackageDBStackCWD+  , usePackageIndex :: Maybe InstalledPackageIndex+  , useProgramDb :: ProgramDb+  , useDistPref :: SymbolicPath Pkg (Dir Dist)+  , useLoggingHandle :: Maybe Handle+  , useWorkingDir :: Maybe (SymbolicPath CWD (Dir Pkg))+  , useExtraPathEnv :: [FilePath]+  -- ^ Extra things to add to PATH when invoking the setup script.+  , useExtraEnvOverrides :: [(String, Maybe FilePath)]+  -- ^ Extra environment variables paired with overrides, where+  --+  -- * @'Just' v@ means \"set the environment variable's value to @v@\".+  -- * 'Nothing' means \"unset the environment variable\".+  , useDependencies :: [(ComponentId, PackageId)]+  -- ^ List of dependencies to use when building Setup.hs.+  , useDependenciesExclusive :: Bool+  -- ^ Is the list of setup dependencies exclusive?+  --+  -- When this is @False@, if we compile the Setup.hs script we do so with the+  -- list in 'useDependencies' but all other packages in the environment are+  -- also visible. A suitable version of @Cabal@ library (see+  -- 'useCabalVersion') is also added to the list of dependencies, unless+  -- 'useDependencies' already contains a Cabal dependency.+  --+  -- When @True@, only the 'useDependencies' packages are used, with other+  -- packages in the environment hidden.+  --+  -- This feature is here to support the setup stanza in .cabal files that+  -- specifies explicit (and exclusive) dependencies, as well as the old+  -- style with no dependencies.+  , useVersionMacros :: Bool+  -- ^ Should we build the Setup.hs with CPP version macros available?+  -- We turn this on when we have a setup stanza in .cabal that declares+  -- explicit setup dependencies.+  , -- Used only by 'cabal clean' on Windows.+    --+    -- Note: win32 clean hack+    -------------------------+    -- On Windows, running './dist/setup/setup clean' doesn't work because the+    -- setup script will try to delete itself (which causes it to fail horribly,+    -- unlike on Linux). So we have to move the setup exe out of the way first+    -- and then delete it manually. This applies only to the external setup+    -- method.+    useWin32CleanHack :: Bool+  , -- Used only when calling setupWrapper from parallel code to serialise+    -- access to the setup cache; should be Nothing otherwise.+    --+    -- Note: setup exe cache+    ------------------------+    -- When we are installing in parallel, we always use the external setup+    -- method. Since compiling the setup script each time adds noticeable+    -- overhead, we use a shared setup script cache+    -- ('$XDG_CACHE_HOME/cabal/setup-exe-cache'). For each (compiler, platform, Cabal+    -- version) combination the cache holds a compiled setup script+    -- executable. This only affects the Simple build type; for the Custom+    -- and Configure build types we always compile the setup script anew.+    setupCacheLock :: Maybe Lock+  , isInteractive :: Bool+  -- ^ Is the task we are going to run an interactive foreground task,+  -- or an non-interactive background task? Based on this flag we+  -- decide whether or not to delegate ctrl+c to the spawned task+  , isMainLibOrExeComponent :: Bool+  -- ^ Let the setup script logic know if it is being run to build a main+  -- library or executable component.  This is used to determine if we should+  -- use the configure command, if the build-type is 'Configure'.  For+  -- configure, only the main library and execomponents have 'configure'+  -- support, and thus we can skip running configure for other components.+  }++defaultSetupScriptOptions :: SetupScriptOptions+defaultSetupScriptOptions =+  SetupScriptOptions+    { useCabalVersion = anyVersion+    , useCabalSpecVersion = Nothing+    , useCompiler = Nothing+    , usePlatform = Nothing+    , usePackageDB = [GlobalPackageDB, UserPackageDB]+    , usePackageIndex = Nothing+    , useDependencies = []+    , useDependenciesExclusive = False+    , useVersionMacros = False+    , useProgramDb = emptyProgramDb+    , useDistPref = defaultDistPref+    , useLoggingHandle = Nothing+    , useWorkingDir = Nothing+    , useExtraPathEnv = []+    , useExtraEnvOverrides = []+    , useWin32CleanHack = False+    , setupCacheLock = Nothing+    , isInteractive = False+    , isMainLibOrExeComponent = True+    }++workingDir :: SetupScriptOptions -> FilePath+workingDir options = case useWorkingDir options of+  Just dir+    | let fp = getSymbolicPath dir+    , not $ null fp+    -> fp+  _ -> "."++-- | A @SetupRunner@ implements a 'SetupMethod'.+type SetupRunner kind =+  Verbosity+  -> SetupScriptOptions+  -> BuildType+  -> [String]+  -> SetupRunnerArgs kind+  -> IO (SetupRunnerRes kind)++-- | Prepare to build a package by configuring a 'SetupMethod'. The returned+-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed+-- during the configuration process; the final values are given by+-- 'setupScriptOptions'.+getSetup+  :: Verbosity+  -> SetupScriptOptions+  -> Maybe PackageDescription+  -> AllowInLibrary+  -> IO ASetup+getSetup verbosity options mpkg allowInLibrary = do+  pkg <- maybe getPkg return mpkg+  let options' =+        options+          { useCabalVersion =+              intersectVersionRanges+                (useCabalVersion options)+                (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))+          }+      -- We retain Configure only for the main library and executable components.+      -- For other components, we rewrite the buildType to Simple to skip the+      -- configure step.  This is because the configure step is not supported for+      -- other components.  Configure can only impact MainLib and Exe through+      -- .buildinfo files.+      buildType' = case (buildType pkg, isMainLibOrExeComponent options) of+        (Configure, False) -> Simple+        (bt, _) -> bt+  withSetupMethod verbosity options' pkg buildType' allowInLibrary $+    \ (version, method, options'') ->+        ASetup $ Setup+          { setupMethod = method+          , setupScriptOptions = options''+          , setupVersion = version+          , setupBuildType = buildType'+          , setupPackage = pkg+          }+  where+    mbWorkDir = useWorkingDir options+    getPkg =+      (tryFindPackageDesc verbosity mbWorkDir >>= readGenericPackageDescription verbosity mbWorkDir . relativeSymbolicPath)+        <&> packageDescription++-- | Decide if we're going to be able to do a direct internal call to the+-- entry point in the Cabal library or if we're going to have to compile+-- and execute an external Setup.hs script.+withSetupMethod+  :: Verbosity+  -> SetupScriptOptions+  -> PackageDescription+  -> BuildType+  -> AllowInLibrary+  -> ( forall kind. (Version, SetupMethod kind, SetupScriptOptions ) -> r )+  -> IO r+withSetupMethod verbosity options pkg buildType' allowInLibrary with+  | buildType' == Custom+      || maybe False (cabalVersion /=) (useCabalSpecVersion options)+      || not (cabalVersion `withinRange` useCabalVersion options)+      || allowInLibrary == Don'tAllowInLibrary+      || (buildType' == Hooks && not hasHooksMain) =+      withExternalSetupMethod+  | buildType' == Hooks = do+      -- NB: needs 'hooksMain' available in Cabal to compile the external+      -- hooks executable, hence the 'not hasHooksMain' guard above.+      compileExternalExe verbosity options pkg buildType' WantHooks+      externalHooksABI <-+        externalSetupHooksABI verbosity $+          hooksProgFilePath (useWorkingDir options) (useDistPref options)+      let internalHooksABI = hooksVersion+      if externalHooksABI == internalHooksABI+        then do+          debug verbosity "Using in-library setup method with build-type Hooks."+          return $ with (cabalVersion, LibraryMethod, options)+        else do+          debug verbosity "Hooks ABI mismatch; falling back to external setup method."+          withExternalSetupMethod+  | otherwise = do+      debug verbosity $ "Using in-library setup method with build-type " ++ show buildType'+      return $ with (cabalVersion, LibraryMethod, options)+  where+    hasHooksMain =+      case cabalLibFromOptions options of+        Just (v, _) -> v >= mkVersion [3, 17]+        Nothing     -> False+    withExternalSetupMethod = do+      debug verbosity $ "Using external setup method with build-type " ++ show buildType'+      debug verbosity $+        "Using explicit dependencies: "+          ++ show (useDependenciesExclusive options)+      with <$> compileExternalExe verbosity options pkg buildType' WantSetup++runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup)+runSetupMethod (ExternalMethod path) = externalSetupMethod path++-- | Run a configured 'Setup' with specific arguments.+runSetup+  :: Verbosity+  -> Setup GeneralSetup+  -> [String]+  -- ^ command-line arguments+  -> SetupRunnerArgs UseGeneralSetup+  -> IO (SetupRunnerRes UseGeneralSetup)+runSetup verbosity setup args0 setupArgs = do+  let method = setupMethod setup+      options = setupScriptOptions setup+      bt = setupBuildType setup+      args = verbosityHack (setupVersion setup) args0+  when (verbosityLevel verbosity >= Deafening {- avoid test if not debug -} && args /= args0) $+    infoNoWrap (verbosity { verbosityFlags = verbose }) $+      "Applied verbosity hack:\n"+        ++ "  Before: "+        ++ show args0+        ++ "\n"+        ++ "  After:  "+        ++ show args+        ++ "\n"+  runSetupMethod method verbosity options bt args setupArgs++-- | This is a horrible hack to make sure passing fancy verbosity+-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on+-- old Setup.  We can't do it in 'filterConfigureFlags' because+-- verbosity applies to ALL commands.+verbosityHack :: Version -> [String] -> [String]+verbosityHack ver args0+  | ver >= mkVersion [2, 1] = args0+  | otherwise = go args0+  where+    go (('-' : 'v' : rest) : args)+      | Just rest' <- munch rest = ("-v" ++ rest') : go args+    go (('-' : '-' : 'v' : 'e' : 'r' : 'b' : 'o' : 's' : 'e' : '=' : rest) : args)+      | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args+    go ("--verbose" : rest : args)+      | Just rest' <- munch rest = "--verbose" : rest' : go args+    go rest@("--" : _) = rest+    go (arg : args) = arg : go args+    go [] = []++    munch rest =+      case runReadE flagToVerbosity rest of+        Right v+          | ver < mkVersion [2, 0]+          , verboseHasFlags v ->+              -- We could preserve the prefix, but since we're assuming+              -- it's Cabal's verbosity flag, we can assume that+              -- any format is OK+              Just (showForCabal (verboseNoFlags v))+          | ver < mkVersion [2, 1]+          , isVerboseTimestamp v ->+              -- +timestamp wasn't yet available in Cabal-2.0.0+              Just (showForCabal (verboseNoTimestamp v))+        _ -> Nothing++-- | Run a command through a configured 'Setup'.+runSetupCommand+  :: Verbosity+  -> Setup GeneralSetup+  -> CommandUI flags+  -- ^ command definition+  -> (flags -> CommonSetupFlags)+  -> flags+  -- ^ command flags+  -> [String]+  -- ^ extra command-line arguments+  -> SetupRunnerArgs UseGeneralSetup+  -> IO (SetupRunnerRes UseGeneralSetup)+runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs setupArgs =+  -- The 'setupWorkingDir' flag corresponds to a global argument which needs to+  -- be passed before the individual command (e.g. 'configure' or 'build').+  let common = getCommonFlags flags+      globalFlags = mempty { globalWorkingDir = setupWorkingDir common }+      args = commandShowOptions (globalCommand []) globalFlags+          ++ (commandName cmd : commandShowOptions cmd flags ++ extraArgs)+  in runSetup verbosity setup args setupArgs++-- | Configure a 'Setup' and run a command in one step. The command flags+-- may depend on the Cabal library version in use.+setupWrapper+  :: forall setupSpec flags+  .  RightFlagsForPhase flags setupSpec+  => Verbosity+  -> SetupScriptOptions+  -> Maybe PackageDescription+  -> CommandUI flags+  -> (flags -> CommonSetupFlags)+  -> (Version -> IO flags)+  -- ^ produce command flags given the Cabal library version+  -> (Version -> [String])+  -> SetupRunnerArgs setupSpec+  -> IO (SetupRunnerRes setupSpec)+setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wrapperArgs = do+  let allowInLibrary = case wrapperArgs of+        InLibraryArgs {} -> AllowInLibrary+        NotInLibrary -> Don'tAllowInLibrary+  ASetup (setup :: Setup kind) <- getSetup verbosity options mpkg allowInLibrary+  let version = setupVersion setup+  flags <- getFlags version+  let+    verbHandles = verbosityHandles verbosity+    extraArgs = getExtraArgs version+    notInLibraryMethod :: kind ~ GeneralSetup => IO (SetupRunnerRes setupSpec)+    notInLibraryMethod = do+      runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs NotInLibrary+      return $ case wrapperArgs of+       NotInLibrary -> ()+       InLibraryArgs libArgs ->+         case libArgs of+           InLibraryConfigureArgs {} -> NotInLibraryNoLBI+           InLibraryPostConfigureArgs sPhase _ ->+             case sPhase of+               SBuildPhase    -> []+               SHaddockPhase  -> []+               SReplPhase     -> []+               SCopyPhase     -> ()+               SRegisterPhase -> ()+               STestPhase     -> ()+               SBenchPhase    -> ()+  case setupMethod setup of+    LibraryMethod ->+      case wrapperArgs of+        InLibraryArgs libArgs ->+          case libArgs of+            InLibraryConfigureArgs elabSharedConfig elabReadyPkg ipiTVar -> do+              -- Start from the pre-configured compiler ProgramDb, augmented+              -- with all builtin programs (restored as unconfigured).+              -- This ensures:+              --   (a) configureAllKnownPrograms inside configureFinal skips+              --       compiler programs (already configured at project level),+              --   (b) builtin preprocessors like alex and happy are present as+              --       unconfigured programs, so configureFinal's+              --       configureAllKnownPrograms can find them using the+              --       per-package search path (respecting extra-prog-path).+              -- See (1) in Note [Constructing the ProgramDb].++              -- Apply per-package user-supplied program args/paths.+              -- See (2)(a) in Note [Constructing the ProgramDb]+              baseProgDb <-+                -- Use 'mkProgramDb' to pass user-supplied per-package+                -- program options (--PROG-options=...).+                mkProgramDb verbHandles flags+                  (restoreProgramDb builtinPrograms $+                    pkgConfigCompilerProgs elabSharedConfig)+              setupProgDb <-+                prependProgramSearchPath verbosity+                  (useExtraPathEnv options)+                  (useExtraEnvOverrides options)+                  baseProgDb+              -- Read the project InstalledPackageIndex to avoid needing to query+              -- @ghc-pkg@ to obtain it.+              -- in Distribution.Client.ProjectBuilding.+              ipi <- readTVarIO ipiTVar+              lbi0 <-+                InLibrary.configure+                  (InLibrary.libraryConfigureInputsFromElabPackage+                     verbHandles+                     (setupBuildType setup)+                     setupProgDb+                     elabSharedConfig+                     elabReadyPkg+                     ipi+                     extraArgs+                  )+                  flags+              let progs0 = LBI.withPrograms lbi0+              -- See (2)(b) in Note [Constructing the ProgramDb]+              progs1 <- updatePathProgDb verbosity progs0+              let+                  lbi =+                    lbi0+                      { LBI.withPrograms = progs1+                      }+                  mbWorkDir = useWorkingDir options+                  distPref = useDistPref options+              -- Write the LocalBuildInfo to disk. This is needed, for instance, if we+              -- skip re-configuring; we retrieve the LocalBuildInfo stored on disk from+              -- the previous invocation of 'configure' and pass it to 'build'.+              writePersistBuildConfig mbWorkDir distPref lbi+              return (InLibraryLBI lbi)+            InLibraryPostConfigureArgs sPhase mbLBI ->+              case mbLBI of+                NotInLibraryNoLBI ->+                  error "internal error: in-library post-conf but no LBI"+                  -- To avoid running into the above error, we must ensure that+                  -- when we skip re-configuring, we retrieve the cached+                  -- LocalBuildInfo (see "whenReconfigure"+                  --   in Distribution.Client.ProjectBuilding.UnpackedPackage).+                InLibraryLBI lbi ->+                  case sPhase of+                    SBuildPhase    -> InLibrary.build    verbHandles flags lbi extraArgs+                    SHaddockPhase  -> InLibrary.haddock  verbHandles flags lbi extraArgs+                    SReplPhase     -> InLibrary.repl     verbHandles flags lbi extraArgs+                    SCopyPhase     -> InLibrary.copy     verbHandles flags lbi extraArgs+                    STestPhase     -> InLibrary.test     verbHandles flags lbi extraArgs+                    SBenchPhase    -> InLibrary.bench    verbHandles flags lbi extraArgs+                    SRegisterPhase -> InLibrary.register             flags lbi extraArgs+        NotInLibrary ->+          error "internal error: NotInLibrary argument but getSetup chose InLibrary"+    ExternalMethod {} -> notInLibraryMethod++{- Note [Constructing the ProgramDb]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When using the in-library method for configuring a package, we want to start off+with the information cabal-install already has in hand, such as the compiler.+Specifically, we skip 'Cabal.Distribution.Simple.preConfigurePackage', which+includes the call to 'configCompilerEx'.++To obtain a program database with all the required information, we do a few+things:++  (1) We retrieve the pre-configured compiler program database (typically+      containing ghc, ghc-pkg, haddock, and toolchain programs such as ar, ld),+      and restore all builtin programs (alex, happy, hsc2hs, ...) as unconfigured+      entries on top of it.++      This serves two purposes:++        (a) The compiler programs (ghc, ghc-pkg, haddock, hsc2hs, ...) that were+            already configured at the project level appear in 'configuredProgs'.+            The 'configureAllKnownPrograms' call inside the Cabal per-package+            'configureFinal' skips them, saving redundant work.++        (b) Builtin preprocessors (e.g. alex, happy) are NOT configured at the+            project level; restoring them here means the call to+            'configureAllKnownPrograms' in 'configureFinal' can find them using+            the per-package search path (including 'extra-prog-path').++  (2)+    (a) When building a package with internal build tools, we must ensure that+        these build tools are available in PATH, with appropriate environment+        variable overrides for their data directory. To do this, we call+        'prependProgramSearchPath'.++    (b) Moreover, these programs must be available in the search paths for the+        compiler itself, in case they are run at compile-time (e.g. with a Template+        Haskell splice). We achieve this using 'updatePathProgDb'.+-}++-- ------------------------------------------------------------++-- * 'invoke' function++-- ------------------------------------------------------------++invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO ()+invoke verbosity path args options = do+  info verbosity $ unwords (path : args)+  case useLoggingHandle options of+    Nothing -> return ()+    Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle++  progDb <- prependProgramSearchPath verbosity (useExtraPathEnv options) (useExtraEnvOverrides options) (useProgramDb options)++  searchpath <-+    programSearchPathAsPATHVar $ getProgramSearchPath progDb++  env <-+    getEffectiveEnvironment $+      [ ("PATH", Just searchpath)+      , ("HASKELL_DIST_DIR", Just (getSymbolicPath $ useDistPref options))+      ]+        ++ progOverrideEnv progDb++  let loggingHandle = maybe Inherit UseHandle (useLoggingHandle options)+      cp =+        (proc path args)+          { Process.cwd = fmap getSymbolicPath $ useWorkingDir options+          , Process.env = env+          , Process.std_out = loggingHandle+          , Process.std_err = loggingHandle+          , Process.delegate_ctlc = isInteractive options+          }+  maybeExit $ rawSystemProc verbosity cp++-- ------------------------------------------------------------++-- * External SetupMethod++-- ------------------------------------------------------------++externalSetupMethod :: WithCallStack (FilePath -> SetupRunner UseGeneralSetup)+externalSetupMethod path verbosity options _ args NotInLibrary =+#ifndef mingw32_HOST_OS+  invoke+    verbosity+    path+    args+    options+#else+    -- See 'Note: win32 clean hack' above.+    if useWin32CleanHack options+      then invokeWithWin32CleanHack path+      else invoke' path+  where+    invoke' p = invoke verbosity p args options++    invokeWithWin32CleanHack origPath = do+      info verbosity $ "Using the Win32 clean hack."+      -- Recursively removes the temp dir on exit.+      withTempDirectory (workingDir options) "cabal-tmp" $ \tmpDir ->+        bracket+          (moveOutOfTheWay tmpDir origPath)+          (\tmpPath -> maybeRestore origPath tmpPath)+          (\tmpPath -> invoke' tmpPath)++    moveOutOfTheWay tmpDir origPath = do+      let tmpPath = tmpDir </> takeFileName origPath+      Win32.moveFile origPath tmpPath+      return tmpPath++    maybeRestore origPath tmpPath = do+      let origPathDir = takeDirectory origPath+      origPathDirExists <- doesDirectoryExist origPathDir+      -- 'setup clean' didn't complete, 'dist/setup' still exists.+      when origPathDirExists $+        Win32.moveFile tmpPath origPath++#endif++useCachedSetupExecutable :: BuildType -> Bool+useCachedSetupExecutable bt =+  bt == Simple || bt == Configure++data ExternalExe = HooksExe | SetupExe+data WantedExternalExe (meth :: ExternalExe) where+  WantHooks :: WantedExternalExe HooksExe+  WantSetup :: WantedExternalExe SetupExe++compileExternalExe+  :: Verbosity+  -> SetupScriptOptions+  -> PackageDescription+  -> BuildType+  -> WantedExternalExe exe+  -> IO (If (exe == HooksExe) () (Version, SetupMethod GeneralSetup, SetupScriptOptions))+compileExternalExe verbosity options pkg bt wantedExe = do+  createDirectoryIfMissingVerbose verbosity True $ i (setupDir options)+  (cabalLibVersion, mCabalLibInstalledPkgId, options') <-+    cabalLibVersionToUse verbosity options (package pkg) bt wantedExe+  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion+  exePath <-+    if useCachedSetupExecutable bt+      then+        getCachedSetupExecutable+          verbosity+          platform+          (package pkg)+          bt+          options'+          cabalLibVersion+          mCabalLibInstalledPkgId+      else+        compileExe+          verbosity+          platform+          (package pkg)+          bt+          wantedExe+          options'+          cabalLibVersion+          mCabalLibInstalledPkgId+          False++  -- Since useWorkingDir can change the relative path, the path argument must+  -- be turned into an absolute path. On some systems, runProcess' will take+  -- path as relative to the new working directory instead of the current+  -- working directory.+  exePath' <- tryCanonicalizePath exePath++  -- See 'Note: win32 clean hack' above.+#ifdef mingw32_HOST_OS+  -- setupProgFile may not exist if we're using a cached program+  setupProgFile' <- canonicalizePathNoThrow $ i (setupProgFile options)+  let win32CleanHackNeeded =+        (useWin32CleanHack options)+          -- Skip when a cached setup script is used.+          && setupProgFile' `equalFilePath` exePath'+#else+  let win32CleanHackNeeded = False+#endif+  let options'' = options'{useWin32CleanHack = win32CleanHackNeeded}++  case wantedExe of+    WantHooks -> return ()+    WantSetup -> return (cabalLibVersion, ExternalMethod exePath', options'')+  where+    mbWorkDir = useWorkingDir options+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    i :: SymbolicPathX allowAbs Pkg to -> FilePath+    i = interpretSymbolicPath mbWorkDir+    platform = fromMaybe buildPlatform (usePlatform options)++-- | Extract the Cabal library version from 'SetupScriptOptions' if it is+-- already determined: either by the solver via 'useDependencies', or directly+-- via 'useCabalSpecVersion' (used for build-type: Custom packages whose+-- setup-depends does not include a transitive Cabal dependency).+cabalLibFromOptions+  :: SetupScriptOptions+  -> Maybe (Version, Maybe ComponentId)+cabalLibFromOptions options =+  case find (isCabalPkgId . snd) (useDependencies options) of+    Just (unitId, pkgId) -> Just (pkgVersion pkgId, Just unitId)+    Nothing ->+      case useCabalSpecVersion options of+        Just version -> Just (version, Nothing)+        Nothing      -> Nothing++-- | Choose the version of Cabal to use if the setup script has a dependency+-- on Cabal. With v2 commands, 'cabalLibFromOptions' returns 'Just ...' and+-- we use that. With v1 commands, we fall back to a bunch of heuristics+-- (see 'v1CabalLibVersionToUse').+cabalLibVersionToUse+  :: Verbosity+  -> SetupScriptOptions+  -> PackageId+  -> BuildType+  -> WantedExternalExe exe+  -> IO (Version, Maybe ComponentId, SetupScriptOptions)+cabalLibVersionToUse verbosity options pkgId bt wantedExe =+  case cabalLibFromOptions options of+    Just (version, mUnitId) -> do+      updateSetupScript verbosity options version bt+      writeSetupVersionFile version+      return (version, mUnitId, options)+    Nothing ->+      v1CabalLibVersionToUse verbosity options pkgId bt wantedExe+  where+    writeSetupVersionFile :: Version -> IO ()+    writeSetupVersionFile version =+      writeFile+        (interpretSymbolicPath (useWorkingDir options) (setupVersionFile options))+        (show version ++ "\n")++-- | Update a Setup.hs script, creating it if necessary.+updateSetupScript :: Verbosity -> SetupScriptOptions -> Version -> BuildType -> IO ()+updateSetupScript verbosity options _ Custom = do+  useHs <- doesFileExist customSetupHs+  useLhs <- doesFileExist customSetupLhs+  unless (useHs || useLhs) $+    dieWithException verbosity UpdateSetupScript+  let src = if useHs then customSetupHs else customSetupLhs+  srcNewer <- src `moreRecentFile` i (setupHs options)+  when srcNewer $+    if useHs+      then copyFileVerbose verbosity src (i (setupHs options))+      else runSimplePreProcessor ppUnlit src (i (setupHs options)) verbosity+  where+    customSetupHs = workingDir options </> "Setup.hs"+    customSetupLhs = workingDir options </> "Setup.lhs"+    i = interpretSymbolicPath (useWorkingDir options)+updateSetupScript verbosity options cabalLibVersion Hooks = do+  let customSetupHooks = workingDir options </> "SetupHooks.hs"+  useHs <- doesFileExist customSetupHooks+  unless useHs $+    die' verbosity "Using 'build-type: Hooks' but there is no SetupHooks.hs file."+  copyFileVerbose verbosity customSetupHooks (i (setupHooks options))+  rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript Hooks cabalLibVersion)+  rewriteFileLBS verbosity (i (hooksHs options)) hooksExeScript+  where+    i = interpretSymbolicPath (useWorkingDir options)+updateSetupScript verbosity options cabalLibVersion bt' =+  rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript bt' cabalLibVersion)+  where+    i = interpretSymbolicPath (useWorkingDir options)++-- | The source code for a non-Custom 'Setup' executable.+buildTypeScript :: BuildType -> Version -> BS.ByteString+buildTypeScript bt cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of+  Simple -> "import Distribution.Simple; main = defaultMain\n"+  Configure+    | cabalLibVersion >= mkVersion [3, 13, 0]+    -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n"+    | cabalLibVersion >= mkVersion [1, 3, 10]+    -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"+    | otherwise+    -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"+  Make -> error "buildtypeScript Make is no longer supported"+  Hooks+    | cabalLibVersion >= mkVersion [3, 13, 0]+    -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n"+    | otherwise+    -> error "buildTypeScript Hooks with Cabal < 3.13"+  Custom -> error "buildTypeScript Custom"++-- | The source code for an external hooks executable.+hooksExeScript :: BS.ByteString+hooksExeScript =+  "{-# LANGUAGE NoImplicitPrelude #-}\nimport Distribution.Simple.SetupHooks.HooksMain (hooksMain); import SetupHooks; main = hooksMain setupHooks\n"++-- | Figure out which compiler we are using to compile the Setup script.+configureCompiler+  :: Verbosity+  -> SetupScriptOptions+  -> IO (Compiler, ProgramDb, SetupScriptOptions)+configureCompiler verbosity options' = do+  (comp, progdb) <- case useCompiler options' of+    Just comp -> return (comp, useProgramDb options')+    Nothing -> do+      (comp, _, progdb) <-+        configCompilerEx+          (Just GHC)+          Nothing+          Nothing+          (useProgramDb options')+          verbosity+      return (comp, progdb)+  -- Whenever we need to call configureCompiler, we also need to access the+  -- package index, so let's cache it in SetupScriptOptions.+  index <- maybeGetInstalledPackages verbosity options' comp progdb+  return+    ( comp+    , progdb+    , options'+        { useCompiler = Just comp+        , usePackageIndex = Just index+        , useProgramDb = progdb+        }+    )++maybeGetInstalledPackages+  :: Verbosity+  -> SetupScriptOptions+  -> Compiler+  -> ProgramDb+  -> IO InstalledPackageIndex+maybeGetInstalledPackages verbosity options' comp progdb =+  case usePackageIndex options' of+    Just index -> return index+    Nothing ->+      getInstalledPackages+        verbosity+        comp+        (usePackageDB options')+        progdb++-- | Path to the setup exe cache directory and path to the cached setup+-- executable.+cachedSetupDirAndProg+  :: Platform+  -> BuildType+  -> SetupScriptOptions+  -> Version+  -> IO (FilePath, FilePath)+cachedSetupDirAndProg platform bt options' cabalLibVersion = do+  cacheDir <- defaultCacheDir+  let setupCacheDir = cacheDir </> "setup-exe-cache"+      cachedSetupProgFile =+        setupCacheDir+          </> ( "setup-"+                  ++ buildTypeString+                  ++ "-"+                  ++ cabalVersionString+                  ++ "-"+                  ++ platformString+                  ++ "-"+                  ++ compilerVersionString+              )+          <.> exeExtension buildPlatform+  return (setupCacheDir, cachedSetupProgFile)+  where+    buildTypeString = show bt+    cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion+    compilerVersionString =+      prettyShow $+        maybe buildCompilerId compilerId $+          useCompiler options'+    platformString = prettyShow platform++-- | Look up the executable in the cache; update the cache if the executable+-- is not found.+getCachedSetupExecutable+  :: Verbosity+  -> Platform+  -> PackageIdentifier+  -> BuildType+  -> SetupScriptOptions+  -> Version+  -> Maybe InstalledPackageId+  -> IO FilePath+getCachedSetupExecutable+  verbosity+  platform+  pkgId+  bt+  options'+  cabalLibVersion+  maybeCabalLibInstalledPkgId = do+    (setupCacheDir, cachedSetupProgFile) <-+      cachedSetupDirAndProg platform bt options' cabalLibVersion+    cachedSetupExists <- doesFileExist cachedSetupProgFile+    if cachedSetupExists+      then+        debug verbosity $+          "Found cached setup executable: " ++ cachedSetupProgFile+      else criticalSection' $ do+        -- The cache may have been populated while we were waiting.+        cachedSetupExists' <- doesFileExist cachedSetupProgFile+        if cachedSetupExists'+          then+            debug verbosity $+              "Found cached setup executable: " ++ cachedSetupProgFile+          else do+            debug verbosity "Setup executable not found in the cache."+            src <-+              compileExe+                verbosity+                platform+                pkgId+                bt+                WantSetup+                options'+                cabalLibVersion+                maybeCabalLibInstalledPkgId+                True+            createDirectoryIfMissingVerbose verbosity True setupCacheDir+            installExecutableFile verbosity src cachedSetupProgFile+            -- Do not strip if we're using GHCJS, since the result may be a script+            when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do+              -- Add the relevant PATH overrides for the package to the+              -- program database.+              setupProgDb+                <- prependProgramSearchPath verbosity+                      (useExtraPathEnv options')+                      (useExtraEnvOverrides options')+                      (useProgramDb options')+                     >>= configureAllKnownPrograms verbosity+              Strip.stripExe+                verbosity+                platform+                setupProgDb+                cachedSetupProgFile+    return cachedSetupProgFile+    where+      criticalSection' = maybe id criticalSection $ setupCacheLock options'++-- | If the Setup.hs is out of date wrt the executable then recompile it.+-- Currently this is GHC/GHCJS only. It should really be generalised.+compileExe+  :: Verbosity+  -> Platform+  -> PackageIdentifier+  -> BuildType+  -> WantedExternalExe exe+  -> SetupScriptOptions+  -> Version+  -> Maybe ComponentId+  -> Bool+  -> IO FilePath+compileExe verbosity platform pkgId bt wantedExe opts ver mbCompId forceCompile =+  case wantedExe of+    WantHooks ->+      compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile+    WantSetup ->+      compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile++compileSetupScript+  :: Verbosity+  -> Platform+  -> PackageIdentifier+  -> BuildType+  -> SetupScriptOptions+  -> Version+  -> Maybe ComponentId+  -> Bool+  -> IO FilePath+compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile =+  compileSetupX "Setup"+    [setupHs opts] (setupProgFile opts)+    verbosity platform pkgId bt opts ver mbCompId forceCompile++compileHooksScript+  :: Verbosity+  -> Platform+  -> PackageIdentifier+  -> SetupScriptOptions+  -> Version+  -> Maybe ComponentId+  -> Bool+  -> IO FilePath+compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile =+  compileSetupX "SetupHooks"+    [setupHooks opts, hooksHs opts] (hooksProgFile opts)+    verbosity platform pkgId Hooks opts ver mbCompId forceCompile++setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup)+setupDir opts = useDistPref opts Cabal.Path.</> makeRelativePathEx "setup"+setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File+setupVersionFile opts = setupDir opts Cabal.Path.</> makeRelativePathEx ( "setup" <.> "version" )+setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File+setupHs opts = setupDir opts Cabal.Path.</> makeRelativePathEx ( "setup" <.> "hs" )+hooksHs opts = setupDir opts Cabal.Path.</> makeRelativePathEx ( "hooks" <.> "hs" )+setupHooks opts = setupDir opts Cabal.Path.</> makeRelativePathEx ( "SetupHooks" <.> "hs" )+setupProgFile opts = setupDir opts Cabal.Path.</> makeRelativePathEx ( "setup" <.> exeExtension buildPlatform )+hooksProgFile opts = setupDir opts Cabal.Path.</> makeRelativePathEx ( "hooks" <.> exeExtension buildPlatform )++compileSetupX+  :: String+  -> [SymbolicPath Pkg File] -- input files+  -> SymbolicPath Pkg File   -- output file+  -> Verbosity+  -> Platform+  -> PackageIdentifier+  -> BuildType+  -> SetupScriptOptions+  -> Version+  -> Maybe ComponentId+  -> Bool+  -> IO FilePath+compileSetupX+  what+  inPaths outPath+  verbosity+  platform+  pkgId+  bt+  options'+  cabalLibVersion+  maybeCabalLibInstalledPkgId+  forceCompile = do+    setupXHsNewer <-+      or <$> for inPaths (\ inPath -> i inPath `moreRecentFile` i outPath)+    cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath+    let outOfDate = setupXHsNewer || cabalVersionNewer+    when (outOfDate || forceCompile) $ do+      debug verbosity $ what ++ " executable needs to be updated, compiling..."+      (compiler, progdb, options'') <- configureCompiler verbosity options'+      pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options''))+      let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion+          (program, extraOpts) =+            case compilerFlavor compiler of+              GHCJS -> (ghcjsProgram, ["-build-runner"])+              _ -> (ghcProgram, ["-threaded"])+          cabalDep =+            maybe+              []+              (\ipkgid -> [(ipkgid, cabalPkgid)])+              maybeCabalLibInstalledPkgId++          -- With 'useDependenciesExclusive' and Custom build type,+          -- we enforce the deps specified, so only the given ones can be used.+          -- Otherwise we add on a dep on the Cabal library+          -- (unless 'useDependencies' already contains one).+          selectedDeps+            |  (useDependenciesExclusive options' && (bt /= Hooks))+            -- NB: to compile build-type: Hooks packages, we need Cabal+            -- in order to compile @main = defaultMainWithSetupHooks setupHooks@.+            || any (isCabalPkgId . snd) (useDependencies options')+            = useDependencies options'+            | otherwise =+                useDependencies options' ++ cabalDep+          addRenaming (ipid, _) =+            -- Assert 'DefUnitId' invariant+            ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))+            , defaultRenaming+            )+          cppMacrosFile = setupDir options' Cabal.Path.</> makeRelativePathEx "setup_macros.h"+          ghcOptions =+            mempty+              { -- Respect -v0, but don't crank up verbosity on GHC if+                -- Cabal verbosity is requested. For that, use+                -- --ghc-option=-v instead!+                ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal+              , ghcOptMode = Flag GhcModeMake+              , ghcOptInputFiles = toNubListR inPaths+              , ghcOptOutputFile = Flag outPath+              , ghcOptObjDir = Flag (setupDir options')+              , ghcOptHiDir = Flag (setupDir options')+              , ghcOptSourcePathClear = Flag True+              , ghcOptSourcePath = case bt of+                  Custom -> toNubListR [sameDirectory]+                  Hooks -> toNubListR [sameDirectory]+                  _ -> mempty+              , ghcOptPackageDBs = pkgDbs+              , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')+              , ghcOptCabal = Flag (useDependenciesExclusive options')+              , ghcOptPackages = toNubListR $ map addRenaming selectedDeps+              -- With 'useVersionMacros', use a version CPP macros .h file.+              , ghcOptCppIncludes =+                  toNubListR+                    [ cppMacrosFile+                    | useVersionMacros options'+                    ]+              , ghcOptExtra = extraOpts+              , ghcOptExtensions = toNubListR $+                  [ Simple.DisableExtension Simple.ImplicitPrelude+                  | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps+                  ]+                  -- Pass -WNoImplicitPrelude to avoid depending on base+                  -- when compiling a simple Setup.hs file.+              , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler+              }+      let ghcCmdLine = renderGhcOptions compiler platform ghcOptions+      when (useVersionMacros options') $+        rewriteFileEx verbosity (i cppMacrosFile) $+          generatePackageVersionMacros (pkgVersion pkgId) (map snd selectedDeps)+      case useLoggingHandle options' of+        Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine+        -- If build logging is enabled, redirect compiler output to+        -- the log file.+        Just logHandle -> do+          output <-+            getDbProgramOutputCwd+              verbosity+              mbWorkDir+              program+              progdb+              ghcCmdLine+          hPutStr logHandle output+    return $ i outPath+  where+    mbWorkDir = useWorkingDir options'+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    i :: SymbolicPathX allowAbs Pkg to -> FilePath+    i = interpretSymbolicPath mbWorkDir++isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool+isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"+isBasePkgId (PackageIdentifier pname _) = pname == mkPackageName "base"++--------------------------------------------------------------------------------+-- THE FORSAKEN ZONE: v1-only logic+--+-- Hopefully we can get rid of all of this before long, simplifying this+-- annoyingly complex module.+--+-- The v1 code path corresponds to 'useDependencies' being unset+-- (no pre-computed dependencies by the solver).++-- | **v1-only**+--+-- Fallback logic to find which Cabal library version to use: try the previously+-- saved version first, then search for available versions in the installed+-- package index, picking a "best" option heuristically.+v1CabalLibVersionToUse+  :: Verbosity+  -> SetupScriptOptions+  -> PackageId+  -> BuildType+  -> WantedExternalExe exe+  -> IO (Version, Maybe ComponentId, SetupScriptOptions)+v1CabalLibVersionToUse verbosity options pkgId bt wantedExe = do+  savedVer <- savedVersion+  case savedVer of+    Just version | version `withinRange` useCabalVersion options ->+      do+        updateSetupScript verbosity options version bt+        -- Does the previously compiled setup executable+        -- still exist and is it up-to date?+        useExisting <- canUseExistingSetup version+        if useExisting+          then return (version, Nothing, options)+          else installedVersion+    _ -> installedVersion+  where+    platform = fromMaybe buildPlatform (usePlatform options)++    i :: SymbolicPath Pkg File -> FilePath+    i = interpretSymbolicPath (useWorkingDir options)++    writeSetupVersionFile :: Version -> IO ()+    writeSetupVersionFile version =+      writeFile (i (setupVersionFile options)) (show version ++ "\n")++    savedVersion :: IO (Maybe Version)+    savedVersion = do+      versionString <- readFile (i (setupVersionFile options)) `catchIO` \_ -> return ""+      case reads versionString of+        [(version, s)] | all isSpace s -> return (Just version)+        _ -> return Nothing++    -- This check duplicates the checks in 'getCachedSetupExecutable' /+    -- 'compileExe'. Unfortunately, we have to perform it twice because the+    -- selected Cabal version may change as a result of this check.+    canUseExistingSetup :: Version -> IO Bool+    canUseExistingSetup version =+      if useCachedSetupExecutable bt+        then do+          (_, cachedSetupProgFile) <- cachedSetupDirAndProg platform bt options version+          doesFileExist cachedSetupProgFile+        else case wantedExe of+          WantSetup ->+            (&&)+              <$> i (setupProgFile options) `existsAndIsMoreRecentThan` i (setupHs options)+              <*> i (setupProgFile options) `existsAndIsMoreRecentThan` i (setupVersionFile options)+          WantHooks ->+            (&&)+              <$> i (hooksProgFile options) `existsAndIsMoreRecentThan` i (setupHooks options)+              <*> i (hooksProgFile options) `existsAndIsMoreRecentThan` i (setupVersionFile options)++    installedVersion :: IO (Version, Maybe ComponentId, SetupScriptOptions)+    installedVersion = do+      (comp, progdb, options') <- configureCompiler verbosity options+      (version, mipkgid, options'') <-+        installedCabalVersion verbosity pkgId bt options' comp progdb+      updateSetupScript verbosity options version bt+      writeSetupVersionFile version+      return (version, mipkgid, options'')++-- | **v1-only**+--+-- Find the version of the installed @Cabal@ package that satisfies the+-- version range in 'useCabalVersion'.+installedCabalVersion+  :: Verbosity+  -> PackageId+  -> BuildType+  -> SetupScriptOptions+  -> Compiler+  -> ProgramDb+  -> IO+      ( Version+      , Maybe InstalledPackageId+      , SetupScriptOptions+      )+installedCabalVersion _verbosity pkgId bt options' _ _+  | packageName pkgId == mkPackageName "Cabal"+      && bt == Custom =+      return (packageVersion pkgId, Nothing, options')+installedCabalVersion verbosity pkgId _bt options' compiler progdb = do+  index <- maybeGetInstalledPackages verbosity options' compiler progdb+  let cabalDepName = mkPackageName "Cabal"+      cabalDepVersion = useCabalVersion options'+      options'' = options'{usePackageIndex = Just index}+  case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of+    [] ->+      dieWithException verbosity $ InstalledCabalVersion (packageName pkgId) (useCabalVersion options')+    pkgs ->+      let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs+          err = error "Distribution.Client.installedCabalVersion: empty version list"+       in return+            ( packageVersion ipkginfo+            , Just . IPI.installedComponentId $ ipkginfo+            , options''+            )++-- | **v1-only**+--+-- Pick the best version from a non-empty list, preferring the one that+-- matches or is closest to the currently running @cabal-install@\'s own+-- @Cabal@ library version.+bestVersion :: (a -> Version) -> [a] -> a+bestVersion f = firstMaximumBy (comparing (preference . f))+  where+    -- Like maximumBy, but picks the first maximum element instead of the+    -- last. In general, we expect the preferred version to go first in the+    -- list. For the default case, this has the effect of choosing the version+    -- installed in the user package DB instead of the global one. See #1463.+    --+    -- Note: firstMaximumBy could be written as just+    -- `maximumBy cmp . reverse`, but the problem is that the behaviour of+    -- maximumBy is not fully specified in the case when there is not a single+    -- greatest element.+    firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a+    firstMaximumBy _ [] =+      error "Distribution.Client.firstMaximumBy: empty list"+    firstMaximumBy cmp xs = foldl1' maxBy xs+      where+        maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y++    preference version =+      ( sameVersion+      , sameMajorVersion+      , stableVersion+      , latestVersion+      )+      where+        sameVersion = version == cabalVersion+        sameMajorVersion = majorVersion version == majorVersion cabalVersion+        majorVersion = take 2 . versionNumbers+        stableVersion = case versionNumbers version of+          (_ : x : _) -> even x+          _ -> False+        latestVersion = version++-- End of v1-only logic+--------------------------------------------------------------------------------
src/Distribution/Client/SolverInstallPlan.hs view
@@ -94,18 +94,6 @@   }   deriving (Generic) -{---- | Much like 'planPkgIdOf', but mapping back to full packages.-planPkgOf :: SolverInstallPlan-          -> Graph.Vertex-          -> SolverPlanPackage-planPkgOf plan v =-    case Graph.lookupKey (planIndex plan)-                         (planPkgIdOf plan v) of-      Just pkg -> pkg-      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"--}- instance Binary SolverInstallPlan instance Structured SolverInstallPlan @@ -166,7 +154,7 @@   -> SolverInstallPlan   -> Either       [SolverPlanProblem]-      (SolverInstallPlan)+      SolverInstallPlan remove shouldRemove plan =   new (planIndepGoals plan) newIndex   where@@ -262,7 +250,7 @@        | pkg <- Foldable.toList index        , Just pkg' <-           map-            (flip Graph.lookup index)+            (`Graph.lookup` index)             (nodeNeighbors pkg)        , not (stateDependencyRelation pkg pkg')        ]
src/Distribution/Client/SourceFiles.hs view
@@ -12,6 +12,7 @@ -- we cannot "see" easily. module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where +import Control.Monad ((>=>)) import Control.Monad.IO.Class  import Distribution.Client.ProjectPlanning.Types@@ -38,7 +39,7 @@ import Distribution.ModuleName  import Distribution.Client.Compat.Prelude-import Distribution.Verbosity (normal)+import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity, normal) import Prelude ()  import System.FilePath@@ -81,7 +82,9 @@     CBench bench -> needBenchmark pkg_descr bench  needSetup :: Rebuild ()-needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return ()+needSetup = do+  void $ findFirstFileMonitored id ["Setup.hs", "Setup.lhs"]+  void $ findFirstFileMonitored id ["SetupHooks.hs", "SetupHooks.lhs"]  needLibrary :: PackageDescription -> Library -> Rebuild () needLibrary@@ -173,7 +176,12 @@   expandedExtraSrcFiles <- liftIO $     fmap concat . for (extraSrcFiles pkg_descr) $       \fpath ->-        matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) (Just $ makeSymbolicPath root) fpath+        matchDirFileGlobWithDie+          (mkVerbosity defaultVerbosityHandles normal)+          (\_ _ -> return [])+          (specVersion pkg_descr)+          (Just $ makeSymbolicPath root)+          fpath   traverse_ needIfExists $     concat       [ map getSymbolicPath $ cSources bi@@ -181,11 +189,13 @@       , map getSymbolicPath $ jsSources bi       , map getSymbolicPath $ cmmSources bi       , map getSymbolicPath $ asmSources bi-      , map getSymbolicPath $ expandedExtraSrcFiles+      , map getSymbolicPath expandedExtraSrcFiles       ]-  for_ (fmap getSymbolicPath $ installIncludes bi) $ \f ->-    findFileMonitored ("." : fmap getSymbolicPath (includeDirs bi)) f-      >>= maybe (return ()) need+  for_+    (fmap getSymbolicPath $ installIncludes bi)+    ( findFileMonitored ("." : fmap getSymbolicPath (includeDirs bi))+        >=> maybe (return ()) need+    )   where     findNeededModules :: [Suffix] -> Rebuild ()     findNeededModules exts =
src/Distribution/Client/SrcDist.hs view
@@ -20,7 +20,7 @@ import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.Simple.PreProcess (knownSuffixHandlers) import Distribution.Simple.SrcDist (listPackageSourcesWithDie)-import Distribution.Simple.Utils (dieWithException)+import Distribution.Simple.Utils (dieWithException, ordNub) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import Distribution.Utils.Path   ( getSymbolicPath@@ -70,7 +70,7 @@   absDir <- canonicalizePath dir   files' <- listPackageSourcesWithDie verbosity dieWithException (Just $ makeSymbolicPath absDir) (flattenPackageDescription gpd) knownSuffixHandlers   let files :: [FilePath]-      files = nub $ sort $ map (normalise . getSymbolicPath) files'+      files = ordNub $ sort $ map (normalise . getSymbolicPath) files'    let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()       entriesM = do
src/Distribution/Client/Store.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -34,21 +33,13 @@   , info   , withTempDirectory   )-import Distribution.Verbosity-  ( silent-  )  import Control.Exception import qualified Data.Set as Set+import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock) import System.Directory import System.FilePath--#ifdef MIN_VERSION_lukko-import Lukko-#else-import System.IO (openFile, IOMode(ReadWriteMode), hClose)-import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock)-#endif+import System.IO (IOMode (ReadWriteMode), hClose, openFile)  -- $concurrency --@@ -214,7 +205,7 @@             -- Atomically rename the temp dir to the final store entry location.             renameDirectory incomingEntryDir finalEntryDir             for_ otherFiles $ \file -> do-              let finalStoreFile = storeDirectory compiler </> makeRelative (normalise $ incomingTmpDir </> (dropDrive (storeDirectory compiler))) file+              let finalStoreFile = storeDirectory compiler </> makeRelative (normalise $ incomingTmpDir </> dropDrive (storeDirectory compiler)) file               createDirectoryIfMissing True (takeDirectory finalStoreFile)               renameFile file finalStoreFile @@ -233,7 +224,7 @@   -> IO a withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compiler action = do   createDirectoryIfMissing True incomingDir-  withTempDirectory silent incomingDir "new" action+  withTempDirectory incomingDir "new" action   where     incomingDir = storeIncomingDirectory compiler @@ -253,36 +244,17 @@     bracket takeLock releaseLock (\_hnd -> action)     where       compid = compilerId compiler-#ifdef MIN_VERSION_lukko-      takeLock-          | fileLockingSupported = do-              fd <- fdOpen (storeIncomingLock compiler unitid)-              gotLock <- fdTryLock fd ExclusiveLock-              unless gotLock  $ do-                  info verbosity $ "Waiting for file lock on store entry "-                                ++ prettyShow compid </> prettyShow unitid-                  fdLock fd ExclusiveLock-              return fd--          -- if there's no locking, do nothing. Be careful on AIX.-          | otherwise = return undefined -- :(--      releaseLock fd-          | fileLockingSupported = do-              fdUnlock fd-              fdClose fd-          | otherwise = return ()-#else       takeLock = do         h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode         -- First try non-blocking, but if we would have to wait then         -- log an explanation and do it again in blocking mode.         gotlock <- hTryLock h ExclusiveLock         unless gotlock $ do-          info verbosity $ "Waiting for file lock on store entry "-                        ++ prettyShow compid </> prettyShow unitid+          info verbosity $+            "Waiting for file lock on store entry "+              ++ prettyShow compid+              </> prettyShow unitid           hLock h ExclusiveLock         return h        releaseLock h = hUnlock h >> hClose h-#endif
src/Distribution/Client/Tar.hs view
@@ -56,10 +56,7 @@ -- | Is this a type code for a build tree reference? isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool isBuildTreeRefTypeCode typeCode-  | ( typeCode == buildTreeRefTypeCode-        || typeCode == buildTreeSnapshotTypeCode-    ) =-      True+  | typeCode == buildTreeRefTypeCode || typeCode == buildTreeSnapshotTypeCode = True   | otherwise = False  filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e
src/Distribution/Client/TargetSelector.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}--- TODO-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- @@ -100,6 +100,7 @@ import Control.Monad hiding   ( mfilter   )+import Data.Bifunctor (second) #if MIN_VERSION_base(4,20,0) import Data.Functor as UZ (unzip) #else@@ -164,8 +165,8 @@  -- ------------------------------------------------------------ --- | A target selector is expression selecting a set of components (as targets--- for a actions like @build@, @run@, @test@ etc). A target selector+-- | A target selector is an expression selecting a set of components (as targets+-- for actions like @build@, @run@, @test@ etc). A target selector -- corresponds to the user syntax for referring to targets on the command line. -- -- From the users point of view a target can be many things: packages, dirs,@@ -257,7 +258,7 @@ readTargetSelectors = readTargetSelectorsWith defaultDirActions  readTargetSelectorsWith-  :: (Applicative m, Monad m)+  :: Monad m   => DirActions m   -> [PackageSpecifier (SourcePackage (PackageLocation a))]   -> Maybe ComponentKindFilter@@ -325,7 +326,7 @@ parseTargetString =   readPToMaybe parseTargetApprox   where-    parseTargetApprox :: Parse.ReadP r TargetString+    parseTargetApprox :: Parse.ReadP TargetString     parseTargetApprox =       ( do           a <- tokenQEnd@@ -390,7 +391,7 @@     tokenQ0 = parseHaskellString <++ token0     tokenEnd = Parse.munch1 (/= ':')     tokenQEnd = parseHaskellString <++ tokenEnd-    parseHaskellString :: Parse.ReadP r String+    parseHaskellString :: Parse.ReadP String     parseHaskellString = Parse.readS_to_P reads  -- | Render a 'TargetString' back as the external syntax. This is mainly for@@ -454,7 +455,7 @@ noFileStatus = FileStatusNotExists False  getTargetStringFileStatus-  :: (Applicative m, Monad m)+  :: Monad m   => DirActions m   -> TargetString   -> m TargetStringFileStatus@@ -764,9 +765,7 @@           Left             ( originalMatch             , [ (forgetFileStatus rendering, matches)-              | rendering <- matchRenderings-              , let Match m _ matches =-                      memoisedMatches Map.! rendering+              | rendering@((memoisedMatches Map.!?) -> Just (Match m _ matches)) <- matchRenderings               , m /= Inexact               ]             )@@ -810,7 +809,7 @@         $ map           ( \(rendering, matches) ->               ( showTargetString rendering-              , (map (\match -> showTargetSelector match ++ " (" ++ showTargetSelectorKind match ++ ")") matches)+              , map (\match -> showTargetSelector match ++ " (" ++ showTargetSelectorKind match ++ ")") matches               )           )           renderingsAndMatches@@ -827,7 +826,7 @@     targets ->       dieWithException verbosity $         NoSuchTargetSelectorErr $-          map (\(target, nosuch) -> (showTargetString target, nosuch)) targets+          map (first showTargetString) targets    case [(t, ts) | TargetSelectorAmbiguous t ts <- problems] of     [] -> return ()@@ -837,7 +836,7 @@           map             ( \(target, amb) ->                 ( showTargetString target-                , (map (\(ut, bt) -> (showTargetString ut, showTargetSelectorKind bt)) amb)+                , map (\(ut, bt) -> (showTargetString ut, showTargetSelectorKind bt)) amb                 )             )             targets@@ -1106,7 +1105,7 @@   -- all the other forms we don't require that.   syntaxForm1 render $ \str1 fstatus1 ->     expecting "file" str1 $ do-      (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) <-+      (pkgfile, KnownPackage{pinfoId, pinfoComponents}) <-         -- always returns the KnownPackage case         matchPackageDirectoryPrefix ps fstatus1       orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do@@ -1133,7 +1132,7 @@       [TargetStringFileStatus2 "" noFileStatus "all"]     render _ = [] --- | Syntax:  all : filer+-- | Syntax:  all : filter -- -- > cabal build all:tests syntaxForm2AllFilter :: Syntax@@ -1147,7 +1146,7 @@       [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)]     render _ = [] --- | Syntax:  package : filer+-- | Syntax:  package : filter -- -- > cabal build foo:tests syntaxForm2PackageFilter :: [KnownPackage] -> Syntax@@ -1721,44 +1720,41 @@ syntaxForm4 :: Renderer -> Match4 -> Syntax syntaxForm5 :: Renderer -> Match5 -> Syntax syntaxForm7 :: Renderer -> Match7 -> Syntax-syntaxForm1 render f =-  Syntax QL1 match render+syntaxForm1 render f = Syntax QL1 match render   where-    match = \(TargetStringFileStatus1 str1 fstatus1) ->-      f str1 fstatus1+    match = \case+      TargetStringFileStatus1 str1 fstatus1 -> f str1 fstatus1+      _ -> mzero -syntaxForm2 render f =-  Syntax QL2 match render+syntaxForm2 render f = Syntax QL2 match render   where-    match = \(TargetStringFileStatus2 str1 fstatus1 str2) ->-      f str1 fstatus1 str2+    match = \case+      TargetStringFileStatus2 str1 fstatus1 str2 -> f str1 fstatus1 str2+      _ -> mzero -syntaxForm3 render f =-  Syntax QL3 match render+syntaxForm3 render f = Syntax QL3 match render   where-    match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) ->-      f str1 fstatus1 str2 str3+    match = \case+      TargetStringFileStatus3 str1 fstatus1 str2 str3 -> f str1 fstatus1 str2 str3+      _ -> mzero -syntaxForm4 render f =-  Syntax QLFull match render+syntaxForm4 render f = Syntax QLFull match render   where-    match (TargetStringFileStatus4 str1 str2 str3 str4) =-      f str1 str2 str3 str4-    match _ = mzero+    match = \case+      TargetStringFileStatus4 str1 str2 str3 str4 -> f str1 str2 str3 str4+      _ -> mzero -syntaxForm5 render f =-  Syntax QLFull match render+syntaxForm5 render f = Syntax QLFull match render   where-    match (TargetStringFileStatus5 str1 str2 str3 str4 str5) =-      f str1 str2 str3 str4 str5-    match _ = mzero+    match = \case+      TargetStringFileStatus5 str1 str2 str3 str4 str5 -> f str1 str2 str3 str4 str5+      _ -> mzero -syntaxForm7 render f =-  Syntax QLFull match render+syntaxForm7 render f = Syntax QLFull match render   where-    match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) =-      f str1 str2 str3 str4 str5 str6 str7-    match _ = mzero+    match = \case+      TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7 -> f str1 str2 str3 str4 str5 str6 str7+      _ -> mzero  dispP :: Package p => p -> String dispP = prettyShow . packageName@@ -1836,7 +1832,7 @@  getKnownTargets   :: forall m a-   . (Applicative m, Monad m)+   . Monad m   => DirActions m   -> [PackageSpecifier (SourcePackage (PackageLocation a))]   -> m KnownTargets@@ -1872,7 +1868,7 @@       [c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents]  collectKnownPackageInfo-  :: (Applicative m, Monad m)+  :: Monad m   => DirActions m   -> PackageSpecifier (SourcePackage (PackageLocation a))   -> m KnownPackage@@ -2186,7 +2182,7 @@     (map render cs)     $ increaseConfidenceFor     $ matchInexactly-      (\(ck, cn) -> (ck, caseFold cn))+      (second caseFold)       (\c -> (cinfoKind c, cinfoStrName c))       cs       (ckind, str)@@ -2289,7 +2285,7 @@ -- | Compare two filepaths for equality using DirActions' canonicalizePath -- to normalize AND canonicalize filepaths before comparison. compareFilePath-  :: (Applicative m, Monad m)+  :: Monad m   => DirActions m   -> FilePath   -> FilePath@@ -2390,6 +2386,9 @@   mzero = empty   mplus = matchPlus +instance MonadFail Match where+  fail _ = mzero+ (</>) :: Match a -> Match a -> Match a (</>) = matchPlusShadowing @@ -2401,8 +2400,8 @@ -- -- This operator is associative, has unit 'mzero' and is also commutative. matchPlus :: Match a -> Match a -> Match a-matchPlus a@(Match _ _ _) (NoMatch _ _) = a-matchPlus (NoMatch _ _) b@(Match _ _ _) = b+matchPlus a@Match{} NoMatch{} = a+matchPlus NoMatch{} b@Match{} = b matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b)   | d_a > d_b = a -- We only really make use of the depth in the NoMatch case.   | d_a < d_b = b@@ -2499,10 +2498,7 @@ -- | A primitive matcher that looks up a value in a finite 'Map'. The -- value must match exactly. matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a)-matchExactly key xs =-  \k -> case Map.lookup k m of-    Nothing -> mzero-    Just ys -> exactMatches ys+matchExactly key xs = \k -> maybe mzero exactMatches (Map.lookup k m)   where     m = Map.fromListWith (++) [(key x, [x]) | x <- xs] @@ -2523,9 +2519,7 @@ matchInexactly cannonicalise key xs =   \k -> case Map.lookup k m of     Just ys -> exactMatches ys-    Nothing -> case Map.lookup (cannonicalise k) m' of-      Just ys -> inexactMatches ys-      Nothing -> mzero+    Nothing -> maybe mzero inexactMatches (Map.lookup (cannonicalise k) m')   where     m = Map.fromListWith (++) [(key x, [x]) | x <- xs]
src/Distribution/Client/Targets.hs view
@@ -82,6 +82,7 @@ import Distribution.Simple.Utils   ( dieWithException   , lowercase+  , ordNub   ) import Distribution.Types.Flag   ( parsecFlagAssignmentNonEmpty@@ -164,16 +165,13 @@  readUserTargets :: Verbosity -> [String] -> IO [UserTarget] readUserTargets verbosity targetStrs = do-  (problems, targets) <--    liftM-      partitionEithers-      (traverse readUserTarget targetStrs)+  (problems, targets) <- partitionEithers <$> traverse readUserTarget targetStrs   reportUserTargetProblems verbosity problems   return targets  data UserTargetProblem   = UserTargetUnexpectedFile String-  | UserTargetNonexistantFile String+  | UserTargetNonexistentFile String   | UserTargetUnexpectedUriScheme String   | UserTargetUnrecognisedUri String   | UserTargetUnrecognised String@@ -210,7 +208,7 @@             | isFile =                 Just (Left (UserTargetUnexpectedFile filename))             | parentDirExists =-                Just (Left (UserTargetNonexistantFile filename))+                Just (Left (UserTargetNonexistentFile filename))             | otherwise =                 Nothing       return result@@ -242,10 +240,10 @@     [] -> return ()     target ->       dieWithException verbosity $ ReportUserTargetProblems target-  case [target | UserTargetNonexistantFile target <- problems] of+  case [target | UserTargetNonexistentFile target <- problems] of     [] -> return ()     target ->-      dieWithException verbosity $ ReportUserTargerNonexistantFile target+      dieWithException verbosity $ ReportUserTargetNonexistentFile target    case [target | UserTargetUnexpectedFile target <- problems] of     [] -> return ()@@ -559,7 +557,7 @@   -> PackageName   -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name =-  case nub (pkgNameLookup name) of+  case ordNub (pkgNameLookup name) of     [] -> None     names -> case find (name ==) names of       Just name' -> Unambiguous name'@@ -609,6 +607,7 @@   deriving (Eq, Show, Generic)  instance Binary UserQualifier+instance NFData UserQualifier instance Structured UserQualifier  -- | Version of 'ConstraintScope' that a user may specify on the@@ -623,6 +622,7 @@   deriving (Eq, Show, Generic)  instance Binary UserConstraintScope+instance NFData UserConstraintScope instance Structured UserConstraintScope  fromUserQualifier :: UserQualifier -> Qualifier@@ -643,6 +643,7 @@   deriving (Eq, Show, Generic)  instance Binary UserConstraint+instance NFData UserConstraint instance Structured UserConstraint  userConstraintPackageName :: UserConstraint -> PackageName
src/Distribution/Client/Types/AllowNewer.hs view
@@ -101,6 +101,12 @@ instance Parsec RelaxedDep where   parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) +instance Parsec AllowOlder where+  parsec = AllowOlder <$> parsec++instance Parsec AllowNewer where+  parsec = AllowNewer <$> parsec+ -- continuation after * relaxedDepStarP :: CabalParsing m => m RelaxedDep relaxedDepStarP =@@ -197,6 +203,14 @@ instance Structured AllowNewer instance Structured AllowOlder +instance NFData RelaxDeps+instance NFData RelaxDepMod+instance NFData RelaxDepScope+instance NFData RelaxDepSubject+instance NFData RelaxedDep+instance NFData AllowNewer+instance NFData AllowOlder+ -- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations -- -- Equivalent to @isRelaxDeps = (/= 'mempty')@@@ -208,7 +222,7 @@ -- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps mkRelaxDepSome xs-  | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs =+  | RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll `elem` xs =       RelaxDepsAll   | otherwise =       RelaxDepsSome xs
src/Distribution/Client/Types/ConfiguredPackage.hs view
@@ -16,6 +16,7 @@ import Distribution.Types.LibraryName (LibraryName (..)) import Distribution.Types.MungedPackageId (computeCompatPackageId) +import Data.Foldable (fold) import Distribution.Client.Types.ConfiguredId import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet) import Distribution.Solver.Types.PackageFixedDeps@@ -65,7 +66,7 @@   -- TODO: if we update ConfiguredPackage to support order-only   -- dependencies, need to include those here.   -- NB: have to deduplicate, otherwise the planner gets confused-  nodeNeighbors = ordNub . CD.flatDeps . depends+  nodeNeighbors = ordNub . fold . depends  instance Binary loc => Binary (ConfiguredPackage loc) @@ -80,4 +81,4 @@   installedUnitId = newSimpleUnitId . confPkgId  instance PackageInstalled (ConfiguredPackage loc) where-  installedDepends = CD.flatDeps . depends+  installedDepends = fold . depends
src/Distribution/Client/Types/InstallMethod.hs view
@@ -14,6 +14,7 @@   deriving (Eq, Show, Generic, Bounded, Enum)  instance Binary InstallMethod+instance NFData InstallMethod instance Structured InstallMethod  -- | Last
src/Distribution/Client/Types/OverwritePolicy.hs view
@@ -15,6 +15,7 @@   deriving (Show, Eq, Generic, Bounded, Enum)  instance Binary OverwritePolicy+instance NFData OverwritePolicy instance Structured OverwritePolicy  instance Parsec OverwritePolicy where
src/Distribution/Client/Types/PackageLocation.hs view
@@ -16,7 +16,8 @@ import Distribution.Types.PackageId (PackageId)  import Distribution.Client.Types.Repo-import Distribution.Client.Types.SourceRepo (SourceRepoMaybe)+import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))+import Distribution.Pretty import Distribution.Solver.Types.SourcePackage (SourcePackage)  type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)@@ -38,6 +39,14 @@   | -- | A package available from a version control system source repository     RemoteSourceRepoPackage SourceRepoMaybe local   deriving (Show, Functor, Eq, Ord, Generic)++instance Pretty (PackageLocation local) where+  pretty (LocalUnpackedPackage fp) = showFilePath fp+  pretty (LocalTarballPackage fp) = showFilePath fp+  pretty (RemoteTarballPackage uri _) = showToken $ show uri+  pretty (RepoTarballPackage repo pid _) = pretty pid <> showToken "@" <> pretty (repoName repo)+  pretty (RemoteSourceRepoPackage sourceRepo _) =+    pretty (srpType sourceRepo) <+> showToken (srpLocation sourceRepo)  instance Binary local => Binary (PackageLocation local) instance Structured local => Structured (PackageLocation local)
src/Distribution/Client/Types/PackageSpecifier.hs view
@@ -59,7 +59,4 @@ mkNamedPackage pkgId =   NamedPackage     (pkgName pkgId)-    ( if pkgVersion pkgId == nullVersion-        then []-        else [PackagePropertyVersion (thisVersion (pkgVersion pkgId))]-    )+    [PackagePropertyVersion (thisVersion $ pkgVersion pkgId) | pkgVersion pkgId /= nullVersion]
src/Distribution/Client/Types/Repo.hs view
@@ -4,6 +4,10 @@   ( -- * Remote repository     RemoteRepo (..)   , emptyRemoteRepo+  , remoteRepoKeyThresholdLens+  , remoteRepoRootKeysLens+  , remoteRepoSecureLens+  , remoteRepoURILens      -- * Local repository (no-index)   , LocalRepo (..)@@ -17,6 +21,7 @@   , maybeRepoRemote      -- * Windows+  , asPosixPath   , normaliseFileNoIndexURI   ) where @@ -29,6 +34,7 @@ import Distribution.System (OS (Windows))  import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)+import Distribution.Compat.Lens  import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Distribution.Compat.CharParsing as P@@ -68,6 +74,7 @@   deriving (Show, Eq, Ord, Generic)  instance Binary RemoteRepo+instance NFData RemoteRepo instance Structured RemoteRepo  instance Pretty RemoteRepo where@@ -97,6 +104,22 @@ emptyRemoteRepo :: RepoName -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False +remoteRepoURILens :: Lens' RemoteRepo URI+remoteRepoURILens f s = fmap (\x -> s{remoteRepoURI = x}) (f (remoteRepoURI s))+{-# INLINE remoteRepoURILens #-}++remoteRepoSecureLens :: Lens' RemoteRepo (Maybe Bool)+remoteRepoSecureLens f s = fmap (\x -> s{remoteRepoSecure = x}) (f (remoteRepoSecure s))+{-# INLINE remoteRepoSecureLens #-}++remoteRepoRootKeysLens :: Lens' RemoteRepo [String]+remoteRepoRootKeysLens f s = fmap (\x -> s{remoteRepoRootKeys = x}) (f (remoteRepoRootKeys s))+{-# INLINE remoteRepoRootKeysLens #-}++remoteRepoKeyThresholdLens :: Lens' RemoteRepo Int+remoteRepoKeyThresholdLens f s = fmap (\x -> s{remoteRepoKeyThreshold = x}) (f (remoteRepoKeyThreshold s))+{-# INLINE remoteRepoKeyThresholdLens #-}+ ------------------------------------------------------------------------------- -- Local repository -------------------------------------------------------------------------------@@ -112,6 +135,7 @@   deriving (Show, Eq, Ord, Generic)  instance Binary LocalRepo+instance NFData LocalRepo instance Structured LocalRepo  -- | Note: doesn't parse 'localRepoSharedCache' field.@@ -170,7 +194,7 @@     -- Although this contains the same fields as 'RepoRemote', we use a separate     -- constructor to avoid confusing the two.     ---    -- Not all access to a secure repo goes through the hackage-security+    -- TODO: Not all access to a secure repo goes through the hackage-security     -- library currently; code paths that do not still make use of the     -- 'repoRemote' and 'repoLocalDir' fields directly.     RepoSecure@@ -180,6 +204,7 @@   deriving (Show, Eq, Ord, Generic)  instance Binary Repo+instance NFData Repo instance Structured Repo  -- | Check if this is a remote repo@@ -230,8 +255,10 @@   , Windows <- os =       URI scheme Nothing (asPosixPath path) query fragment   | otherwise = uri-  where-    asPosixPath p =-      -- We don't use 'isPathSeparator' because @Windows.isPathSeparator-      -- Posix.pathSeparator == True@.-      [if x == Windows.pathSeparator then Posix.pathSeparator else x | x <- p]++-- | Convert a path to POSIX-style.+asPosixPath :: FilePath -> FilePath+asPosixPath p =+  -- We don't use 'isPathSeparator' because @Windows.isPathSeparator+  -- Posix.pathSeparator == True@.+  [if x == Windows.pathSeparator then Posix.pathSeparator else x | x <- p]
src/Distribution/Client/Types/SourceRepo.hs view
@@ -42,6 +42,8 @@ deriving instance Binary (f FilePath) => Binary (SourceRepositoryPackage f) deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) +instance (Typeable f, NFData (f FilePath)) => NFData (SourceRepositoryPackage f)+ -- | Read from @cabal.project@ type SourceRepoList = SourceRepositoryPackage [] @@ -100,7 +102,6 @@  sourceRepositoryPackageGrammar   :: ( FieldGrammar c g-     , Applicative (g SourceRepoList)      , c (Identity RepoType)      , c (List NoCommaFSep FilePathNT String)      , c (NonEmpty' NoCommaFSep Token String)
src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs view
@@ -5,6 +5,8 @@   ) where  import Distribution.Client.Compat.Prelude+import qualified Distribution.Compat.CharParsing as P+import Distribution.Parsec import Prelude ()  -- | Whether 'v2-build' should write a .ghc.environment file after@@ -18,4 +20,18 @@   deriving (Eq, Enum, Bounded, Generic, Show)  instance Binary WriteGhcEnvironmentFilesPolicy+instance NFData WriteGhcEnvironmentFilesPolicy instance Structured WriteGhcEnvironmentFilesPolicy++instance Parsec WriteGhcEnvironmentFilesPolicy where+  parsec = do+    token <- parsecToken+    case token of+      "always" -> return AlwaysWriteGhcEnvironmentFiles+      "never" -> return NeverWriteGhcEnvironmentFiles+      "ghc8.4.4+" -> return WriteGhcEnvironmentFilesOnlyForGhc844AndNewer+      policy ->+        P.unexpected $+          "Cannot parse the GHC environment file write policy '"+            <> policy+            <> "'"
src/Distribution/Client/Upload.hs view
@@ -61,7 +61,7 @@       repos = repoContextRepos repoCtxt   transport <- repoContextGetTransport repoCtxt   targetRepo <--    case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of+    case mapMaybe maybeRepoRemote repos of       [] -> dieWithException verbosity NoRemoteRepositories       (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs))   let targetRepoURI :: URI@@ -120,7 +120,7 @@   let repos = repoContextRepos repoCtxt   transport <- repoContextGetTransport repoCtxt   targetRepo <--    case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of+    case mapMaybe maybeRepoRemote repos of       [] -> dieWithException verbosity NoRemoteRepositories       (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs))   let targetRepoURI = remoteRepoURI targetRepo@@ -232,7 +232,7 @@     -- from this repo yet.     srcExists <- doesDirectoryExist srcDir     when srcExists $ do-      contents <- getDirectoryContents srcDir+      contents <- listDirectory srcDir       for_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->         do           inp <- readFile (srcDir </> logFile)
src/Distribution/Client/Utils.hs view
@@ -15,7 +15,6 @@   , withExtraPathEnv   , determineNumJobs   , numberOfProcessors-  , removeExistingFile   , withTempFileName   , makeAbsoluteToCwd   , makeRelativeToCwd@@ -71,7 +70,7 @@ import Distribution.Compat.Environment import Distribution.Compat.Time (getModTime) import Distribution.Simple.Setup (Flag, pattern Flag, pattern NoFlag)-import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)+import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap, removeFileForcibly) import Distribution.Utils.Path   ( CWD   , FileOrDir (..)@@ -90,8 +89,7 @@   ( canonicalizePath   , doesDirectoryExist   , doesFileExist-  , getDirectoryContents-  , removeFile+  , listDirectory   ) import qualified System.Directory as Directory import System.FilePath@@ -104,10 +102,13 @@   ) import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Set as Set import Data.Time (utcToLocalTime) import Data.Time.Calendar (toGregorian) import Data.Time.Clock.POSIX (getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone, localDay)+import Distribution.Simple.PackageDescription (readGenericPackageDescription)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import GHC.Conc.Sync (getNumProcessors) import GHC.IO.Encoding   ( TextEncoding (TextEncoding)@@ -117,13 +118,8 @@   ( CodingFailureMode (TransliterateCodingFailure)   , recoverEncode   )-#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import qualified System.Directory as Dir import qualified System.IO.Error as IOError-#endif-import qualified Data.Set as Set-import Distribution.Simple.PackageDescription (readGenericPackageDescription)-import Distribution.Types.GenericPackageDescription (GenericPackageDescription)  -- | Generic merging utility. For sorted input lists this is a full outer join. mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]@@ -140,26 +136,18 @@  data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b -duplicates :: Ord a => [a] -> [[a]]+duplicates :: Ord a => [a] -> [NonEmpty a] duplicates = duplicatesBy compare -duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]]-duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp+duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]+duplicatesBy cmp = mapMaybe moreThanOne . groupBy eq . sortBy cmp   where     eq :: a -> a -> Bool     eq a b = case cmp a b of       EQ -> True       _ -> False-    moreThanOne (_ : _ : _) = True-    moreThanOne _ = False---- | Like 'removeFile', but does not throw an exception when the file does not--- exist.-removeExistingFile :: FilePath -> IO ()-removeExistingFile path = do-  exists <- doesFileExist path-  when exists $-    removeFile path+    moreThanOne (x : xs@(_ : _)) = Just (x :| xs)+    moreThanOne _ = Nothing  -- | A variant of 'withTempFile' that only gives us the file name, and while -- it will clean up the file afterwards, it's lenient if the file is@@ -172,7 +160,7 @@ withTempFileName tmpDir template action =   Safe.bracket     (openTempFile tmpDir template)-    (\(name, _) -> removeExistingFile name)+    (\(name, _) -> removeFileForcibly name)     (\(name, h) -> hClose h >> action name)  -- | Executes the action with an environment variable set to some@@ -239,6 +227,7 @@ -- program, so unsafePerformIO is safe here. numberOfProcessors :: Int numberOfProcessors = unsafePerformIO getNumProcessors+{-# NOINLINE numberOfProcessors #-}  -- | Determine the number of jobs to use given the value of the '-j' flag. determineNumJobs :: Flag (Maybe Int) -> Int@@ -305,7 +294,7 @@     conv :: Word32 -> [Word8] -> [Word8]     conv w32 rest = b0 : b1 : b2 : b3 : rest       where-        b0 = fromIntegral $ w32+        b0 = fromIntegral w32         b1 = fromIntegral $ w32 `shiftR` 8         b2 = fromIntegral $ w32 `shiftR` 16         b3 = fromIntegral $ w32 `shiftR` 24@@ -332,18 +321,18 @@  -- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always -- throws an error if the path refers to a non-existent file.-{- FOURMOLU_DISABLE -} tryCanonicalizePath :: FilePath -> IO FilePath tryCanonicalizePath path = do   ret <- canonicalizePath path-#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)   exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)   unless exists $-    IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"-                        Nothing (Just ret)-#endif+    IOError.ioError $+      IOError.mkIOError+        IOError.doesNotExistErrorType+        "canonicalizePath"+        Nothing+        (Just ret)   return ret-{- FOURMOLU_ENABLE -}  -- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws -- an exception, returns the path argument unmodified.@@ -509,12 +498,9 @@ listFilesRecursive :: FilePath -> IO [FilePath] listFilesRecursive = listFilesInside (const $ pure True) --- | From System.Directory.Extra---   https://hackage.haskell.org/package/extra-1.7.9 listContents :: FilePath -> IO [FilePath]-listContents dir = do-  xs <- getDirectoryContents dir-  pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]+listContents dir =+  map (dir </>) . sort <$> listDirectory dir  -- | From Control.Monad.Extra --   https://hackage.haskell.org/package/extra-1.7.9
+ src/Distribution/Client/Utils/Newtypes.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar".+-- Whenever we can not provide a Parsec instance for a type, we need to wrap it in a newtype and define the instance.+module Distribution.Client.Utils.Newtypes+  ( NumJobs (..)+  , PackageDBNT (..)+  , AllowNewerNT (..)+  , AllowOlderNT (..)+  , ProjectConstraints (..)+  , MaxBackjumps (..)+  , URI_NT (..)+  , KeyThreshold (..)+  )+where++import Distribution.Client.Compat.Prelude+import Distribution.Client.Targets (UserConstraint)+import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..))+import Distribution.Compat.CharParsing+import Distribution.Compat.Newtype+import Distribution.Parsec+import Distribution.Simple.Compiler (PackageDBCWD, interpretPackageDB, readPackageDb)+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))+import Network.URI (URI, parseURI)++newtype PackageDBNT = PackageDBNT {getPackageDBNT :: Maybe PackageDBCWD}++instance Newtype (Maybe PackageDBCWD) PackageDBNT++instance Parsec PackageDBNT where+  parsec = parsecPackageDB++parsecPackageDB :: CabalParsing m => m PackageDBNT+parsecPackageDB = PackageDBNT . fmap (interpretPackageDB Nothing) . readPackageDb <$> parsecToken++newtype NumJobs = NumJobs {getNumJobs :: Maybe Int}++instance Newtype (Maybe Int) NumJobs++instance Parsec NumJobs where+  parsec = parsecNumJobs++parsecNumJobs :: CabalParsing m => m NumJobs+parsecNumJobs = ncpus <|> numJobs+  where+    ncpus = string "$ncpus" >> return (NumJobs Nothing)+    numJobs = do+      num <- integral+      if num < (1 :: Int)+        then do+          parsecWarning PWTOther "The number of jobs should be 1 or more."+          return (NumJobs Nothing)+        else return (NumJobs $ Just num)++newtype URI_NT = URI_NT {getURI_NT :: URI}++instance Newtype URI URI_NT++instance Parsec URI_NT where+  parsec = parsecURI_NT++parsecURI_NT :: CabalParsing m => m URI_NT+parsecURI_NT = do+  token <- parsecToken'+  case parseURI token of+    Nothing -> fail $ "failed to parse URI " <> token+    Just uri -> return $ URI_NT uri++newtype KeyThreshold = KeyThreshold {getKeyThreshold :: Int}++instance Newtype Int KeyThreshold++instance Parsec KeyThreshold where+  parsec = KeyThreshold <$> integral++newtype ProjectConstraints = ProjectConstraints {getProjectConstraints :: (UserConstraint, ConstraintSource)}++instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints++instance Parsec ProjectConstraints where+  parsec = parsecProjectConstraints++-- | Parse 'ProjectConstraints'. As the 'CabalParsing' class does not have access to the file we parse,+-- ConstraintSource is first unknown and we set it afterwards+parsecProjectConstraints :: CabalParsing m => m ProjectConstraints+parsecProjectConstraints = do+  userConstraint <- parsec+  return $ ProjectConstraints (userConstraint, ConstraintSourceUnknown)++newtype MaxBackjumps = MaxBackjumps {getMaxBackjumps :: Int}++instance Newtype Int MaxBackjumps++instance Parsec MaxBackjumps where+  parsec = parseMaxBackjumps++parseMaxBackjumps :: CabalParsing m => m MaxBackjumps+parseMaxBackjumps = MaxBackjumps <$> integral++newtype AllowNewerNT = AllowNewerNT {getAllowNewerNT :: Maybe AllowNewer}++instance Newtype (Maybe AllowNewer) AllowNewerNT++instance Parsec AllowNewerNT where+  parsec = parsecAllowNewer++parsecAllowNewer :: CabalParsing m => m AllowNewerNT+parsecAllowNewer = AllowNewerNT . Just <$> parsec++newtype AllowOlderNT = AllowOlderNT {getAllowOlderNT :: Maybe AllowOlder}++instance Newtype (Maybe AllowOlder) AllowOlderNT++instance Parsec AllowOlderNT where+  parsec = parsecAllowOlder++parsecAllowOlder :: CabalParsing m => m AllowOlderNT+parsecAllowOlder = AllowOlderNT . Just <$> parsec
src/Distribution/Client/Utils/Parsec.hs view
@@ -1,105 +1,89 @@-module Distribution.Client.Utils.Parsec-  ( renderParseError-  ) where+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} -import Distribution.Client.Compat.Prelude-import System.FilePath (normalise)-import Prelude ()+module Distribution.Client.Utils.Parsec+  ( remoteRepoGrammar -import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8+    -- ** Flag+  , alaFlag+  , Flag' -import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos)-import Distribution.Simple.Utils (fromUTF8BS)+    -- ** NubList+  , alaNubList+  , alaNubList'+  , NubList' --- | Render parse error highlighting the part of the input file.-renderParseError-  :: FilePath-  -> BS.ByteString-  -> NonEmpty PError-  -> [PWarning]-  -> String-renderParseError filepath contents errors warnings =-  unlines $-    [ "Errors encountered when parsing cabal file " <> filepath <> ":"-    ]-      ++ renderedErrors-      ++ renderedWarnings-  where-    filepath' = normalise filepath+    -- ** Newtype wrappers+  , module Distribution.Client.Utils.Newtypes+  ) where -    -- lines of the input file. 'lines' is taken, so they are called rows-    -- contents, line number, whether it's empty line-    rows :: [(String, Int, Bool)]-    rows = zipWith f (BS8.lines contents) [1 ..]-      where-        f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s)+import Distribution.Client.Compat.Prelude+import Distribution.Compat.Newtype+import Prelude () -    rowsZipper = listToZipper rows+import Distribution.Client.Types.Repo+import Distribution.Client.Types.RepoName+import Distribution.Client.Utils.Newtypes+import Distribution.FieldGrammar+import Distribution.Simple.Flag+import Distribution.Utils.NubList (NubList (..))+import qualified Distribution.Utils.NubList as NubList -    isEmptyOrComment :: String -> Bool-    isEmptyOrComment s = case dropWhile (== ' ') s of-      "" -> True -- empty-      ('-' : '-' : _) -> True -- comment-      _ -> False+-- | Like 'List' for usage with a 'FieldGrammar', but for 'Flag'.+-- This enables to parse type aliases such as 'FilePath' that do not have 'Parsec' instances+-- by using newtype variants such as 'FilePathNT'.+-- For example, if you need to parse a 'Flag FilePath', you can use 'alaFlag' FilePathNT'.+newtype Flag' b a = Flag' {_getFlag :: Flag a} -    renderedErrors = concatMap renderError errors-    renderedWarnings = concatMap renderWarning warnings+-- | 'Flag'' constructor, with additional phantom argument to constrain the resulting type+alaFlag :: (a -> b) -> Flag a -> Flag' b a+alaFlag _ = Flag' -    renderError :: PError -> [String]-    renderError (PError pos@(Position row col) msg)-      -- if position is 0:0, then it doesn't make sense to show input-      -- looks like, Parsec errors have line-feed in them-      | pos == zeroPos = msgs-      | otherwise = msgs ++ formatInput row col-      where-        msgs = ["", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, ""]+instance Newtype (Flag a) (Flag' wrapper a) -    renderWarning :: PWarning -> [String]-    renderWarning (PWarning _ pos@(Position row col) msg)-      | pos == zeroPos = msgs-      | otherwise = msgs ++ formatInput row col-      where-        msgs = ["", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, ""]+instance (Newtype a b, Parsec b) => Parsec (Flag' b a) where+  parsec = pack . toFlag . (unpack :: b -> a) <$> parsec -    -- sometimes there are (especially trailing) newlines.-    trimLF :: String -> String-    trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse+instance (Newtype a b, Pretty b) => Pretty (Flag' b a) where+  pretty = pretty . (pack :: a -> b) . fromFlag . unpack -    -- format line: prepend the given line number-    formatInput :: Int -> Int -> [String]-    formatInput row col = case advance (row - 1) rowsZipper of-      Zipper xs ys -> before ++ after-        where-          before = case span (\(_, _, b) -> b) xs of-            (_, []) -> []-            (zs, z : _) -> map formatInputLine $ z : reverse zs+-- | Like 'List' for usage with a 'FieldGrammar', but for 'NubList'.+newtype NubList' sep b a = NubList' {_getNubList :: NubList a} -          after = case ys of-            [] -> []-            (z : _zs) ->-              [ formatInputLine z -- error line-              , "      | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^-              ]-    -- do we need rows after?-    -- ++ map formatInputLine (take 1 zs)           -- one row after+-- | 'alaNubList' and 'alaNubList'' are simply 'NubList'' constructor, with additional phantom+-- arguments to constrain the resulting type+--+-- >>> :t alaNubList VCat+-- alaNubList VCat :: NubList a -> NubList' VCat (Identity a) a+--+-- >>> :t alaNubList' FSep Token+-- alaNubList' FSep Token+--   :: NubList String -> NubList' FSep Token String+--+-- >>> unpack' (alaNubList' FSep Token) <$> eitherParsec "foo bar foo"+-- Right ["foo","bar"]+alaNubList :: sep -> NubList a -> NubList' sep (Identity a) a+alaNubList _ = NubList' -    formatInputLine :: (String, Int, Bool) -> String-    formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str+-- | More general version of 'alaNubList'.+alaNubList' :: sep -> (a -> b) -> NubList a -> NubList' sep b a+alaNubList' _ _ = NubList' -    -- hopefully we don't need to work with over 99999 lines .cabal files-    -- at that point small glitches in error messages are hopefully fine.-    leftPadShow :: Int -> String-    leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s+instance Newtype (NubList a) (NubList' sep wrapper a) -data Zipper a = Zipper [a] [a]+instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (NubList' sep b a) where+  parsec = pack . NubList.toNubList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec -listToZipper :: [a] -> Zipper a-listToZipper = Zipper []+instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where+  pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NubList.fromNubList . unpack -advance :: Int -> Zipper a -> Zipper a-advance n z@(Zipper xs ys)-  | n <= 0 = z-  | otherwise = case ys of-      [] -> z-      (y : ys') -> advance (n - 1) $ Zipper (y : xs) ys'+remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo+remoteRepoGrammar name =+  pure (RemoteRepo name)+    <*> uniqueFieldAla "url" URI_NT remoteRepoURILens+    <*> optionalField "secure" remoteRepoSecureLens+    <*> monoidalFieldAla "root-keys" (alaList' FSep Token) remoteRepoRootKeysLens+    <*> optionalFieldDefAla "key-threshold" KeyThreshold remoteRepoKeyThresholdLens 0+    <*> pure False -- we don't parse remoteRepoShouldTryHttps
src/Distribution/Client/VCS.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}@@ -73,17 +72,16 @@   , RepoType (..)   ) import Distribution.Verbosity as Verbosity-  ( normal+  ( VerbosityLevel (..)+  , verbosityLevel   ) import Distribution.Version   ( mkVersion   ) -#if !MIN_VERSION_base(4,18,0)-import Control.Applicative-         ( liftA2 )-#endif-+import Control.Concurrent+  ( threadDelay+  ) import Control.Exception   ( throw   , try@@ -97,7 +95,6 @@ import System.Directory   ( doesDirectoryExist   , doesFileExist-  , removeDirectoryRecursive   , removePathForcibly   ) import System.FilePath@@ -331,7 +328,7 @@           Nothing -> []           Just tag -> ["-r", "tag:" ++ tag]         verboseArg :: [String]-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]      vcsSyncRepos       :: Verbosity@@ -384,7 +381,7 @@           Nothing -> []           Just tag -> ["-t", tag]         verboseArg :: [String]-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]      vcsSyncRepos       :: Verbosity@@ -412,7 +409,7 @@               pure ()         Left e | not (isDoesNotExistError e) -> throw e         _ -> do-          removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw+          removePathForcibly localDir           darcs (takeDirectory localDir) cloneArgs       where         darcs :: FilePath -> [String] -> IO ()@@ -436,7 +433,7 @@           Nothing -> []           Just tag -> ["-t" ++ tag]         verboseArg :: [String]-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]  darcsProgram :: Program darcsProgram =@@ -489,7 +486,7 @@           Just b -> ["--branch", b]           Nothing -> []         resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"]-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]      -- Note: No --depth=1 for vcsCloneRepo since that is used for `cabal get -s`,     -- whereas `vcsSyncRepo` is used for source-repository-package where we do want shallow clones.@@ -511,7 +508,7 @@           ]         return           [ monitorDirectoryExistence dir-          | dir <- (primaryLocalDir : map snd secondaryRepos)+          | dir <- primaryLocalDir : map snd secondaryRepos           ]      -- NOTE: Repositories are cloned once, but can be synchronized multiple times.@@ -533,18 +530,15 @@       dotGitModulesExists <- doesDirectoryExist dotGitModulesPath       when dotGitModulesExists $ do         git localDir $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg-        if buildOS == Windows-          then do-            -- Windows can't delete some git files #10182-            void $-              Process.createProcess_ "attrib" $-                Process.shell $-                  "attrib -s -h -r " <> dotGitModulesPath <> "\\*.* /s /d"--            catch-              (removePathForcibly dotGitModulesPath)-              (\e -> if isPermissionError e then removePathForcibly dotGitModulesPath else throw e)-          else removeDirectoryRecursive dotGitModulesPath+        -- Windows can't delete some git files #10182+        when (buildOS == Windows) $+          void $+            Process.createProcess_ "attrib" $+              Process.shell $+                "attrib -s -h -r " <> dotGitModulesPath <> "\\*.* /s /d"+        catch+          (removePathForcibly dotGitModulesPath)+          (\e -> if isPermissionError e then threadDelay 1000 >> removePathForcibly dotGitModulesPath else throw e)        -- If we want a particular branch or tag, fetch it.       ref <- case srpBranch `mplus` srpTag of@@ -576,7 +570,7 @@           --    containing the commit that was just fetched. This feels a bit           --    nasty but seems to work reliably, even if nothing was fetched.           --    (That is, deleting `FETCH_HEAD` and re-running a `git fetch`-          --    command will succesfully recreate the `FETCH_HEAD` ref.)+          --    command will successfully recreate the `FETCH_HEAD` ref.)           --           -- Option 2 is what Cabal has done historically, and we're keeping it           -- for now. Option 1 is possible but seems to have little benefit.@@ -599,7 +593,7 @@         git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg         git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] -      git localDir $ ["clean", "-ffxdq"]+      git localDir ["clean", "-ffxdq"]       where         git :: FilePath -> [String] -> IO ()         git cwd args =@@ -617,7 +611,7 @@           where             loc = srpLocation -        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]  gitProgram :: Program gitProgram =@@ -629,16 +623,15 @@           -- or annoyingly "git version 2.17.1.windows.2" yes, really           (_ : _ : ver : _) ->             intercalate "."-              . takeWhile (all isNum)+              . takeWhile (all isDigit)               . split               $ ver           _ -> ""     }   where-    isNum c = c >= '0' && c <= '9'-    isTypical c = isNum c || c == '.'+    isTypical c = isDigit c || c == '.'     split cs = case break (== '.') cs of-      (chunk, []) -> chunk : []+      (chunk, []) -> [chunk]       (chunk, _ : rest) -> chunk : split rest  -- | VCS driver for Mercurial.@@ -672,7 +665,7 @@         tagArgs = case srpTag repo of           Just t -> ["--rev", t]           Nothing -> []-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]      vcsSyncRepos       :: Verbosity@@ -691,7 +684,7 @@           ]         return           [ monitorDirectoryExistence dir-          | dir <- (primaryLocalDir : map snd secondaryRepos)+          | dir <- primaryLocalDir : map snd secondaryRepos           ]     vcsSyncRepo verbosity hgProg repo localDir = do       exists <- doesDirectoryExist localDir@@ -707,9 +700,9 @@               { progInvokeCwd = Just cwd               }         cloneArgs =-          ["clone", "--noupdate", (srpLocation repo), localDir]+          ["clone", "--noupdate", srpLocation repo, localDir]             ++ verboseArg-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]         checkoutArgs =           ["checkout", "--clean"]             ++ tagArgs@@ -748,7 +741,7 @@       [programInvocation prog checkoutArgs]       where         checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg-        verboseArg = ["--quiet" | verbosity < Verbosity.normal]+        verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal]     -- TODO: branch or tag?      vcsSyncRepos@@ -885,7 +878,7 @@           ]         return           [ monitorDirectoryExistence dir-          | dir <- (primaryLocalDir : map snd secondaryRepos)+          | dir <- primaryLocalDir : map snd secondaryRepos           ]      vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do@@ -924,5 +917,4 @@           _ -> ""     }   where-    isNum c = c >= '0' && c <= '9'-    isTypical c = isNum c || c == '.'+    isTypical c = isDigit c || c == '.'
src/Distribution/Client/Version.hs view
@@ -9,7 +9,11 @@   , cabalInstallGitInfo   ) where +import Data.List (intercalate)+import qualified Data.Version as DV+import qualified Distribution.Compat.SysInfo as SIC import Distribution.Version+import qualified System.Info as SI  import qualified Paths_cabal_install as PackageInfo @@ -29,8 +33,22 @@ cabalInstallVersion = mkVersion' PackageInfo.version  -- |+-- `cabal-install` compiler information.+cabalInstallCompilerInfo :: String+cabalInstallCompilerInfo =+  concat+    [ SI.compilerName+    , " "+    , intercalate "." (map show (DV.versionBranch SIC.fullCompilerVersion))+    , " on "+    , SI.os+    , " "+    , SI.arch+    ]++-- | -- `cabal-install` Git information. Only filled in if built in a Git tree in--- developmnent mode and Template Haskell is available.+-- development mode and Template Haskell is available. cabalInstallGitInfo :: String #ifdef GIT_REV cabalInstallGitInfo = if giHash' == ""@@ -38,16 +56,16 @@                         else concat [ "(commit "                                     , giHash'                                     , branchInfo-                                    , ", "-                                    , either (const "") giCommitDate gi'+                                    , either (const "") ((", " ++) . giCommitDate) gi'                                     , ")"                                     ]   where     gi' = $$tGitInfoCwdTry     giHash' = take 7 . either (const "") giHash $ gi'+    branch = either id giBranch gi'     branchInfo | isLeft gi' = ""-               | either id giBranch gi' == "master" = ""-               | otherwise = " on " <> either id giBranch gi'+               | branch == "master" = ""+               | otherwise = " on " <> branch #else cabalInstallGitInfo = "" #endif
src/Distribution/Client/Win32SelfUpgrade.hs view
@@ -1,9 +1,6 @@+{-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} -------------------------------------------------------------------------------------------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Win32SelfUpgrade -- Copyright   :  (c) Duncan Coutts 2008@@ -57,7 +54,7 @@ import System.Directory (canonicalizePath) import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) -import Distribution.Verbosity as Verbosity (showForCabal)+import Distribution.Verbosity as Verbosity (showForCabal, verbosityFlags) import Distribution.Simple.Utils (debug, info)  @@ -84,7 +81,7 @@       result <- action       scheduleOurDemise verbosity dstPath tmpPath         (\pid path -> ["win32selfupgrade", pid, path-                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])+                      ,"--verbose=" ++ Verbosity.showForCabal (verbosityFlags verbosity)])       return result  -- | The name of a Win32 Event object that we use to synchronise between the@@ -165,17 +162,10 @@  -- A bunch of functions sadly not provided by the Win32 package. -{- FOURMOLU_DISABLE -}-#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "windows.h GetCurrentProcessId"+foreign import capi unsafe "windows.h GetCurrentProcessId"   getCurrentProcessId :: IO DWORD -foreign import CALLCONV unsafe "windows.h WaitForSingleObject"+foreign import capi unsafe "windows.h WaitForSingleObject"   waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD  waitForSingleObject :: HANDLE -> DWORD -> IO ()@@ -186,7 +176,7 @@     bad result   = not (result == 0 || result == wAIT_TIMEOUT)     wAIT_TIMEOUT = 0x00000102 -foreign import CALLCONV unsafe "windows.h CreateEventW"+foreign import capi unsafe "windows.h CreateEventW"   createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE  createEvent :: String -> IO HANDLE@@ -195,7 +185,7 @@     Win32.withTString name $       createEvent_ nullPtr False False -foreign import CALLCONV unsafe "windows.h OpenEventW"+foreign import capi unsafe "windows.h OpenEventW"   openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE  openEvent :: String -> IO HANDLE@@ -207,7 +197,7 @@     eVENT_MODIFY_STATE :: DWORD     eVENT_MODIFY_STATE = 0x0002 -foreign import CALLCONV unsafe "windows.h SetEvent"+foreign import capi unsafe "windows.h SetEvent"   setEvent_ :: HANDLE -> IO BOOL  setEvent :: HANDLE -> IO ()@@ -229,4 +219,3 @@ deleteOldExeFile verbosity _ _ = dieWithException verbosity Win32SelfUpgradeNotNeeded  #endif-{- FOURMOLU_ENABLE -}
src/Distribution/Deprecated/ParseUtils.hs view
@@ -147,7 +147,7 @@ parseFail :: PError -> ParseResult a parseFail = ParseFailed -runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a+runP :: LineNo -> String -> ReadP a -> String -> ParseResult a runP line fieldname p s =   case [x | (x, "") <- results] of     [a] -> ParseOk (utf8Warnings line fieldname s) a@@ -211,7 +211,7 @@   -- successful.  Otherwise, reports an error on line number @n@.   } -field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a+field :: String -> (a -> Doc) -> ReadP a -> FieldDescr a field name showF readF =   FieldDescr name showF (\line val _st -> runP line name readF val) @@ -239,7 +239,7 @@ simpleField   :: String   -> (a -> Doc)-  -> ReadP a a+  -> ReadP a   -> (b -> a)   -> (a -> b -> b)   -> FieldDescr b@@ -260,7 +260,7 @@   :: Semigroup a   => String   -> (a -> Doc)-  -> ReadP a a+  -> ReadP a   -> (b -> a)   -> (a -> b -> b)   -> FieldDescr b@@ -318,7 +318,7 @@ spaceListField   :: String   -> (a -> Doc)-  -> ReadP [a] a+  -> ReadP a   -> (b -> [a])   -> ([a] -> b -> b)   -> FieldDescr b@@ -334,7 +334,7 @@ newLineListField   :: String   -> (a -> Doc)-  -> ReadP [a] a+  -> ReadP a   -> (b -> [a])   -> ([a] -> b -> b)   -> FieldDescr b@@ -344,7 +344,7 @@   :: Separator   -> String   -> (a -> Doc)-  -> ReadP [a] a+  -> ReadP a   -> (b -> [a])   -> ([a] -> b -> b)   -> FieldDescr b@@ -373,7 +373,7 @@ listField   :: String   -> (a -> Doc)-  -> ReadP [a] a+  -> ReadP a   -> (b -> [a])   -> ([a] -> b -> b)   -> FieldDescr b@@ -462,23 +462,23 @@ -- Different than the naive version. it turns out Read instance for String accepts -- the ['a', 'b'] syntax, which we do not want. In particular it messes -- up any token starting with [].-parseHaskellString :: ReadP r String+parseHaskellString :: ReadP String parseHaskellString =   readS_to_P $     Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 -parseTokenQ :: ReadP r String+parseTokenQ :: ReadP String parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')  parseSpaceList-  :: ReadP r a+  :: ReadP a   -- ^ The parser for the stuff between commas-  -> ReadP r [a]+  -> ReadP [a] parseSpaceList p = sepBy p skipSpaces  -- This version avoid parse ambiguity for list element parsers -- that have multiple valid parses of prefixes.-parseOptCommaList :: ReadP r a -> ReadP r [a]+parseOptCommaList :: ReadP a -> ReadP [a] parseOptCommaList p = sepBy p localSep   where     -- The separator must not be empty or it introduces ambiguity@@ -486,7 +486,7 @@       (skipSpaces >> char ',' >> skipSpaces)         +++ (satisfy isSpace >> skipSpaces) -readPToMaybe :: ReadP a a -> String -> Maybe a+readPToMaybe :: ReadP a -> String -> Maybe a readPToMaybe p str =   listToMaybe     [ r | (r, s) <- readP_to_S p str, all isSpace s
src/Distribution/Deprecated/ReadP.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GADTs #-}- -- | -- -- Module      :  Distribution.Deprecated.ReadP@@ -9,64 +7,52 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- This is a library of parser combinators, originally written by Koen Claessen.--- It parses all alternatives in parallel, so it never keeps hold of--- the beginning of the input string, a common source of space leaks with--- other parsers.  The '(+++)' choice combinator is genuinely commutative;--- it makes no difference which branch is \"shorter\".------ See also Koen's paper /Parallel Parsing Processes/--- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).------ This version of ReadP has been locally hacked to make it H98, by--- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>------ The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by--- Mark Lentczner <mailto:mark@glyphic.com>+-- Mostly re-exports of 'Text.ParserCombinators.ReadP', with added type synonym+-- 'Parser', and added functions 'skipSpaces1' and 'readP_to_E'. module Distribution.Deprecated.ReadP   ( -- * The 'ReadP' type-    ReadP -- :: * -> *; instance Functor, Monad, MonadPlus+    T.ReadP      -- * Primitive operations-  , get -- :: ReadP Char-  , look -- :: ReadP String-  , (+++) -- :: ReadP a -> ReadP a -> ReadP a-  , (<++) -- :: ReadP a -> ReadP a -> ReadP a-  , gather -- :: ReadP a -> ReadP (String, a)+  , T.get+  , T.look+  , (T.+++)+  , (T.<++)+  , T.gather      -- * Other operations-  , pfail -- :: ReadP a-  , eof -- :: ReadP ()-  , satisfy -- :: (Char -> Bool) -> ReadP Char-  , char -- :: Char -> ReadP Char-  , string -- :: String -> ReadP String-  , munch -- :: (Char -> Bool) -> ReadP String-  , munch1 -- :: (Char -> Bool) -> ReadP String-  , skipSpaces -- :: ReadP ()-  , skipSpaces1 -- :: ReadP ()-  , choice -- :: [ReadP a] -> ReadP a-  , count -- :: Int -> ReadP a -> ReadP [a]-  , between -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a-  , option -- :: a -> ReadP a -> ReadP a-  , optional -- :: ReadP a -> ReadP ()-  , many -- :: ReadP a -> ReadP [a]-  , many1 -- :: ReadP a -> ReadP [a]-  , skipMany -- :: ReadP a -> ReadP ()-  , skipMany1 -- :: ReadP a -> ReadP ()-  , sepBy -- :: ReadP a -> ReadP sep -> ReadP [a]-  , sepBy1 -- :: ReadP a -> ReadP sep -> ReadP [a]-  , endBy -- :: ReadP a -> ReadP sep -> ReadP [a]-  , endBy1 -- :: ReadP a -> ReadP sep -> ReadP [a]-  , chainr -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  , chainl -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  , chainl1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  , chainr1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  , manyTill -- :: ReadP a -> ReadP end -> ReadP [a]+  , T.pfail+  , T.eof+  , T.satisfy+  , T.char+  , T.string+  , T.munch+  , T.munch1+  , T.skipSpaces+  , skipSpaces1+  , T.choice+  , T.count+  , T.between+  , T.option+  , T.optional+  , T.many+  , T.many1+  , T.skipMany+  , T.skipMany1+  , T.sepBy+  , T.sepBy1+  , T.endBy+  , T.endBy1+  , T.chainr+  , T.chainl+  , T.chainl1+  , T.chainr1+  , T.manyTill      -- * Running a parser-  , ReadS -- :: *; = String -> [(a,String)]-  , readP_to_S -- :: ReadP a -> ReadS a-  , readS_to_P -- :: ReadS a -> ReadP a+  , T.ReadS+  , T.readP_to_S+  , T.readS_to_P   , readP_to_E      -- ** Internal@@ -74,371 +60,20 @@   ) where -import Distribution.Client.Compat.Prelude hiding (get, many)-import Prelude ()--import Control.Monad (replicateM, (>=>))--import qualified Control.Monad.Fail as Fail-+import Distribution.Client.Compat.Prelude import Distribution.ReadE (ReadE (..))--infixr 5 +++, <++---- ------------------------------------------------------------------------------ The P type--- is representation type -- should be kept abstract--data P s a-  = Get (s -> P s a)-  | Look ([s] -> P s a)-  | Fail-  | Result a (P s a)-  | Final [(a, [s])] -- invariant: list is non-empty!---- Monad, MonadPlus--instance Functor (P s) where-  fmap = liftM--instance Applicative (P s) where-  pure x = Result x Fail-  (<*>) = ap--instance Monad (P s) where-  return = pure--  (Get f) >>= k = Get (f >=> k)-  (Look f) >>= k = Look (f >=> k)-  Fail >>= _ = Fail-  (Result x p) >>= k = k x `mplus` (p >>= k)-  (Final r) >>= k = final [ys' | (x, s) <- r, ys' <- run (k x) s]--instance Fail.MonadFail (P s) where-  fail _ = Fail--instance Alternative (P s) where-  empty = mzero-  (<|>) = mplus--instance MonadPlus (P s) where-  mzero = Fail--  -- most common case: two gets are combined-  Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)-  -- results are delivered as soon as possible-  Result x p `mplus` q = Result x (p `mplus` q)-  p `mplus` Result x q = Result x (p `mplus` q)-  -- fail disappears-  Fail `mplus` p = p-  p `mplus` Fail = p-  -- two finals are combined-  -- final + look becomes one look and one final (=optimization)-  -- final + sthg else becomes one look and one final-  Final r `mplus` Final t = Final (r ++ t)-  Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))-  Final r `mplus` p = Look (\s -> Final (r ++ run p s))-  Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))-  p `mplus` Final r = Look (\s -> Final (run p s ++ r))-  -- two looks are combined (=optimization)-  -- look + sthg else floats upwards-  Look f `mplus` Look g = Look (\s -> f s `mplus` g s)-  Look f `mplus` p = Look (\s -> f s `mplus` p)-  p `mplus` Look f = Look (\s -> p `mplus` f s)---- ------------------------------------------------------------------------------ The ReadP type--newtype Parser r s a = R ((a -> P s r) -> P s r)-type ReadP r a = Parser r Char a---- Functor, Monad, MonadPlus--instance Functor (Parser r s) where-  fmap h (R f) = R (\k -> f (k . h))--instance Applicative (Parser r s) where-  pure x = R (\k -> k x)-  (<*>) = ap--instance s ~ Char => Alternative (Parser r s) where-  empty = pfail-  (<|>) = (+++)--instance Monad (Parser r s) where-  return = pure-  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))--instance Fail.MonadFail (Parser r s) where-  fail _ = R (const Fail)--instance s ~ Char => MonadPlus (Parser r s) where-  mzero = pfail-  mplus = (+++)---- ------------------------------------------------------------------------------ Operations over P--final :: [(a, [s])] -> P s a--- Maintains invariant for Final constructor-final [] = Fail-final r = Final r--run :: P c a -> ([c] -> [(a, [c])])-run (Get f) (c : s) = run (f c) s-run (Look f) s = run (f s) s-run (Result x p) s = (x, s) : run p s-run (Final r) _ = r-run _ _ = []---- ------------------------------------------------------------------------------ Operations over ReadP--get :: ReadP r Char--- ^ Consumes and returns the next character.---   Fails if there is no input left.-get = R Get--look :: ReadP r String--- ^ Look-ahead: returns the part of the input that is left, without---   consuming it.-look = R Look--pfail :: ReadP r a--- ^ Always fails.-pfail = R (const Fail)--eof :: ReadP r ()--- ^ Succeeds iff we are at the end of input-eof = do-  s <- look-  if null s-    then return ()-    else pfail--(+++) :: ReadP r a -> ReadP r a -> ReadP r a--- ^ Symmetric choice.-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)--(<++) :: ReadP a a -> ReadP r a -> ReadP r a--- ^ Local, exclusive, left-biased choice: If left parser---   locally produces any result at all, then right parser is---   not used.-R f <++ q =-  do-    s <- look-    probe (f return) s 0-  where-    probe (Get f') (c : s) n = probe (f' c) s (n + 1 :: Int)-    probe (Look f') s n = probe (f' s) s n-    probe p@(Result _ _) _ n = discard n >> R (p >>=)-    probe (Final r) _ _ = R (Final r >>=)-    probe _ _ _ = q--    discard 0 = return ()-    discard n = get >> discard (n - 1 :: Int)--gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)--- ^ Transforms a parser into one that does the same, but---   in addition returns the exact characters read.---   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument---   is built using any occurrences of readS_to_P.-gather (R m) =-  R (\k -> gath id (m (\a -> return (\s -> k (s, a)))))-  where-    gath l (Get f) = Get (\c -> gath (l . (c :)) (f c))-    gath _ Fail = Fail-    gath l (Look f) = Look (gath l . f)-    gath l (Result k p) = k (l []) `mplus` gath l p-    gath _ (Final _) = error "do not use readS_to_P in gather!"---- ------------------------------------------------------------------------------ Derived operations--satisfy :: (Char -> Bool) -> ReadP r Char--- ^ Consumes and returns the next character, if it satisfies the---   specified predicate.-satisfy p = do c <- get; if p c then return c else pfail--char :: Char -> ReadP r Char--- ^ Parses and returns the specified character.-char c = satisfy (c ==)--string :: String -> ReadP r String--- ^ Parses and returns the specified string.-string this = do s <- look; scan this s-  where-    scan [] _ = return this-    scan (x : xs) (y : ys) | x == y = get >> scan xs ys-    scan _ _ = pfail--munch :: (Char -> Bool) -> ReadP r String--- ^ Parses the first zero or more characters satisfying the predicate.-munch p =-  do-    s <- look-    scan s-  where-    scan (c : cs) | p c = do _ <- get; s <- scan cs; return (c : s)-    scan _ = do return ""--munch1 :: (Char -> Bool) -> ReadP r String--- ^ Parses the first one or more characters satisfying the predicate.-munch1 p =-  do-    c <- get-    if p c-      then do s <- munch p; return (c : s)-      else pfail--choice :: [ReadP r a] -> ReadP r a--- ^ Combines all parsers in the specified list.-choice [] = pfail-choice [p] = p-choice (p : ps) = p +++ choice ps+import qualified Text.ParserCombinators.ReadP as T -skipSpaces :: ReadP r ()--- ^ Skips all whitespace.-skipSpaces =-  do-    s <- look-    skip s-  where-    skip (c : s) | isSpace c = do _ <- get; skip s-    skip _ = do return ()+type Parser = T.ReadP -skipSpaces1 :: ReadP r ()+skipSpaces1 :: T.ReadP () -- ^ Like 'skipSpaces' but succeeds only if there is at least one -- whitespace character to skip.-skipSpaces1 = satisfy isSpace >> skipSpaces--count :: Int -> ReadP r a -> ReadP r [a]--- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of---   results is returned.-count n p = replicateM n p--between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a--- ^ @ between open close p @ parses @open@, followed by @p@ and finally---   @close@. Only the value of @p@ is returned.-between open close p = do-  _ <- open-  x <- p-  _ <- close-  return x--option :: a -> ReadP r a -> ReadP r a--- ^ @option x p@ will either parse @p@ or return @x@ without consuming---   any input.-option x p = p +++ return x--optional :: ReadP r a -> ReadP r ()--- ^ @optional p@ optionally parses @p@ and always returns @()@.-optional p = (p >> return ()) +++ return ()--many :: ReadP r a -> ReadP r [a]--- ^ Parses zero or more occurrences of the given parser.-many p = return [] +++ many1 p--many1 :: ReadP r a -> ReadP r [a]--- ^ Parses one or more occurrences of the given parser.-many1 p = liftM2 (:) p (many p)--skipMany :: ReadP r a -> ReadP r ()--- ^ Like 'many', but discards the result.-skipMany p = many p >> return ()--skipMany1 :: ReadP r a -> ReadP r ()--- ^ Like 'many1', but discards the result.-skipMany1 p = p >> skipMany p--sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy p sep = sepBy1 p sep +++ return []--sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy1 p sep = liftM2 (:) p (many (sep >> p))--endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended---   by @sep@.-endBy p sep = many (do x <- p; _ <- sep; return x)--endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended---   by @sep@.-endBy1 p sep = many1 (do x <- p; _ <- sep; return x)--chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /right/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainr p op x = chainr1 p op +++ return x--chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /left/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainl p op x = chainl1 p op +++ return x--chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a--- ^ Like 'chainr', but parses one or more occurrences of @p@.-chainr1 p op = scan-  where-    scan = p >>= rest-    rest x =-      do-        f <- op-        y <- scan-        return (f x y)-        +++ return x--chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a--- ^ Like 'chainl', but parses one or more occurrences of @p@.-chainl1 p op = p >>= rest-  where-    rest x =-      do-        f <- op-        y <- p-        rest (f x y)-        +++ return x--manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@---   succeeds. Returns a list of values returned by @p@.-manyTill p end = scan-  where-    scan = (end >> return []) <++ (liftM2 (:) p scan)---- ------------------------------------------------------------------------------ Converting between ReadP and Read--readP_to_S :: ReadP a a -> ReadS a--- ^ Converts a parser into a Haskell ReadS-style function.---   This is the main way in which you can \"run\" a 'ReadP' parser:---   the expanded type is--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @-readP_to_S (R f) = run (f return)--readS_to_P :: ReadS a -> ReadP r a--- ^ Converts a Haskell ReadS-style function into a parser.---   Warning: This introduces local backtracking in the resulting---   parser, and therefore a possible inefficiency.-readS_to_P r =-  R (\k -> Look (\s -> final [bs'' | (a, s') <- r s, bs'' <- run (k a) s']))------------------------------------------------------------------------------------ ReadE--------------------------------------------------------------------------------+skipSpaces1 = T.satisfy isSpace >> T.skipSpaces -readP_to_E :: (String -> String) -> ReadP a a -> ReadE a+readP_to_E :: (String -> String) -> T.ReadP a -> ReadE a readP_to_E err r =-  ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt, all isSpace s+  ReadE $ \txt -> case [ p | (p, s) <- T.readP_to_S r txt, all isSpace s                        ] of     [] -> Left (err txt)     (p : _) -> Right p
src/Distribution/Deprecated/ViewAsFieldDescr.hs view
@@ -5,7 +5,7 @@ import Distribution.Client.Compat.Prelude hiding (get) import Prelude () -import qualified Data.List.NonEmpty as NE+import Data.Foldable (minimumBy) import Distribution.ReadE (parsecToReadE) import Distribution.Simple.Command import Text.PrettyPrint (cat, comma, punctuate, text)@@ -20,7 +20,7 @@   error "Distribution.command.viewAsFieldDescr: unexpected" viewAsFieldDescr (OptionField n (d : dd)) = FieldDescr n get set   where-    optDescr = head $ NE.sortBy cmp (d :| dd)+    optDescr = minimumBy cmp (d :| dd)      cmp :: OptDescr a -> OptDescr a -> Ordering     ReqArg{} `cmp` ReqArg{} = EQ@@ -53,7 +53,7 @@     --    set :: LineNo -> String -> a -> ParseResult a     set line val a =       case optDescr of-        ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val+        ReqArg _ _ _ readE _ -> ($ a) <$> runE line n readE val         -- We parse for a single value instead of a         -- list, as one can't really implement         -- parseList :: ReadE a -> ReadE [a] with@@ -62,8 +62,8 @@           case getChoiceByLongFlag optDescr val of             Just f -> return (f a)             _ -> syntaxError line val-        BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val-        OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val+        BoolOpt _ _ _ setV _ -> (`setV` a) <$> runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val+        OptArg _ _ _ readE _ _ -> ($ a) <$> runE line n readE val  -- Optional arguments are parsed just like -- required arguments here; we don't
tests/IntegrationTests2.hs view
@@ -54,18 +54,13 @@ import qualified Distribution.Client.CmdTest as CmdTest  import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject-import Distribution.Client.Config (SavedConfig (savedGlobalFlags), createDefaultConfigFile, loadConfig)-import Distribution.Client.GlobalFlags-  ( GlobalFlags-  , defaultGlobalFlags-  , globalNix-  )-import Distribution.Client.Setup (globalCommand, globalStoreDir)+import Distribution.Client.Config (createDefaultConfigFile)+import Distribution.Client.GlobalFlags (defaultGlobalFlags)+import Distribution.Client.Setup (globalStoreDir) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription-import Distribution.Simple.Command import Distribution.Simple.Compiler import qualified Distribution.Simple.Flag as Flag import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag)@@ -73,7 +68,6 @@ import Distribution.Text import Distribution.Utils.Path (unsafeMakeSymbolicPath) import Distribution.Version-import IntegrationTests2.CPP  import Data.List (isInfixOf) import qualified Data.Map as Map@@ -86,6 +80,7 @@ import System.Environment (setEnv) import System.FilePath import System.IO (hPutStrLn, stderr)+import qualified System.Info import System.Process (callProcess)  import Data.Tagged (Tagged (..))@@ -99,9 +94,10 @@ import System.IO.Silently  import qualified Data.ByteString as BS-import Data.Maybe (fromJust)-import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag)+import Distribution.Simple.Flag (pattern Flag)+import Distribution.Simple.Utils (removeFileForcibly) import Distribution.Types.ParStrat+import Distribution.Verbosity  main :: IO () main = do@@ -109,7 +105,7 @@   cwd <- getCurrentDirectory   let configDir = cwd </> basedir </> "config" </> "cabal-config"   setEnv "CABAL_DIR" configDir-  removeDirectoryRecursive configDir <|> return ()+  removePathForcibly configDir <|> return ()   createDirectoryIfMissing True configDir   -- sigh   -- NOTE: This is running the `cabal` from the user environment, which is@@ -119,7 +115,7 @@   defaultMainWithIngredients     (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions])     ( localOption (NumThreads 1) $ withProjectConfig $ \config ->-        sequentialTestGroup+        dependentTestGroup           "Integration tests (internal)"           AllFinish           (tests config)@@ -142,19 +138,23 @@           else res  testCase :: String -> Assertion -> TestTree-testCase desc action = (T.testCase desc action)+testCase desc action = T.testCase desc action  tests :: ProjectConfig -> [TestTree] tests config =   -- TODO: tests for:   -- \* normal success   -- \* dry-run tests with changes-  [ sequentialTestGroup "Discovery and planning" AllFinish $+  [ dependentTestGroup+      "Discovery and planning"+      AllFinish       [ testCase "no package" (testExceptionInFindingPackage config)       , testCase "no package2" (testExceptionInFindingPackage2 config)       , testCase "proj conf1" (testExceptionInProjectConfig config)       ]-  , sequentialTestGroup "Target selectors" AllFinish $+  , dependentTestGroup+      "Target selectors"+      AllFinish       [ testCaseSteps "valid" testTargetSelectors       , testCase "bad syntax" testTargetSelectorBadSyntax       , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous@@ -171,7 +171,9 @@       , testCaseSteps "problems (bench)" (testTargetProblemsBench config)       , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config)       ]-  , sequentialTestGroup "Exceptions during building (local inplace)" AllFinish $+  , dependentTestGroup+      "Exceptions during building (local inplace)"+      AllFinish       [ testCase "configure" (testExceptionInConfigureStep config)       , testCase "build" (testExceptionInBuildStep config)       --    , testCase "register"   testExceptionInRegisterStep@@ -180,28 +182,28 @@     -- TODO: need to check we can build sub-libs, foreign libs and exes     -- components for non-local packages / packages in the store. -    sequentialTestGroup "Successful builds" AllFinish $+    dependentTestGroup "Successful builds" AllFinish $       [ testCaseSteps "Setup script styles" (testSetupScriptStyles config)       , testCase "keep-going" (testBuildKeepGoing config)       ]-        ++ if isMingw32-          then -- disabled because https://github.com/haskell/cabal/issues/6272-            []-          else-            [ testCase "local tarball" (testBuildLocalTarball config)-            ]-  , sequentialTestGroup "Regression tests" AllFinish $+        +++        -- disabled because https://github.com/haskell/cabal/issues/6272+        [testCase "local tarball" (testBuildLocalTarball config) | System.Info.os /= "mingw32"]+  , dependentTestGroup+      "Regression tests"+      AllFinish       [ testCase "issue #3324" (testRegressionIssue3324 config)       , testCase "program options scope all" (testProgramOptionsAll config)       , testCase "program options scope local" (testProgramOptionsLocal config)       , testCase "program options scope specific" (testProgramOptionsSpecific config)       ]-  , sequentialTestGroup "Flag tests" AllFinish $-      [ testCase "Test Nix Flag" testNixFlags-      , testCase "Test Config options for commented options" testConfigOptionComments+  , dependentTestGroup+      "Flag tests"+      AllFinish+      [ testCase "Test Config options for commented options" testConfigOptionComments       , testCase "Test Ignore Project Flag" testIgnoreProjectFlag       ]-  , sequentialTestGroup+  , dependentTestGroup       "haddock-project"       AllFinish       [ testCase "dependencies" (testHaddockProjectDependencies config)@@ -666,7 +668,7 @@               , condSubLibraries = []               , condForeignLibs = []               , condExecutables =-                  [ (exeName exe, CondNode exe [] [])+                  [ (exeName exe, CondNode exe [])                   | exe <- exes                   ]               , condTestSuites = []@@ -955,7 +957,7 @@       CmdBuild.selectPackageTargets       CmdBuild.selectComponentTarget       [mkTargetPackage "p-0.1"]-      [ ("p-0.1-inplace", (CLibName LMainLibName))+      [ ("p-0.1-inplace", CLibName LMainLibName)       , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")       , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")       , ("p-0.1-inplace-an-exe", CExeName "an-exe")@@ -981,7 +983,7 @@       CmdBuild.selectPackageTargets       CmdBuild.selectComponentTarget       [mkTargetPackage "p-0.1"]-      [ ("p-0.1-inplace", (CLibName LMainLibName))+      [ ("p-0.1-inplace", CLibName LMainLibName)       , ("p-0.1-inplace-an-exe", CExeName "an-exe")       , ("p-0.1-inplace-libp", CFLibName "libp")       ]@@ -1156,7 +1158,7 @@       (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False))       CmdRepl.selectComponentTarget       [TargetPackage TargetExplicitNamed ["p-0.1"] Nothing]-      [("p-0.1-inplace", (CLibName LMainLibName))]+      [("p-0.1-inplace", CLibName LMainLibName)]     -- When we select the package with an explicit filter then we get those     -- components even though we did not explicitly enable tests/benchmarks     assertProjectDistinctTargets@@ -1478,7 +1480,7 @@             [ (CTestName "a-testsuite", "TestModule")             , (CBenchName "a-benchmark", "BenchModule")             , (CExeName "an-exe", "ExeModule")-            , ((CLibName LMainLibName), "P")+            , (CLibName LMainLibName, "P")             ]          ]       ++ [ ( const@@ -1632,7 +1634,7 @@             [ (CTestName "a-testsuite", "TestModule")             , (CBenchName "a-benchmark", "BenchModule")             , (CExeName "an-exe", "ExeModule")-            , ((CLibName LMainLibName), "P")+            , (CLibName LMainLibName, "P")             ]          ]       ++ [ ( const@@ -1709,7 +1711,7 @@         (CmdHaddock.selectPackageTargets haddockFlags)         CmdHaddock.selectComponentTarget         [mkTargetPackage "p-0.1"]-        [ ("p-0.1-inplace", (CLibName LMainLibName))+        [ ("p-0.1-inplace", CLibName LMainLibName)         , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")         , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")         , ("p-0.1-inplace-an-exe", CExeName "an-exe")@@ -1725,7 +1727,7 @@         (CmdHaddock.selectPackageTargets haddockFlags)         CmdHaddock.selectComponentTarget         [mkTargetPackage "p-0.1"]-        [("p-0.1-inplace", (CLibName LMainLibName))]+        [("p-0.1-inplace", CLibName LMainLibName)]    reportSubCase "requested component kinds"   -- When we selecting the package with an explicit filter then it does not@@ -1756,7 +1758,7 @@  assertProjectDistinctTargets   :: forall err-   . (Eq err, Show err)+   . Show err   => ElaboratedInstallPlan   -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k])   -> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k)@@ -1912,23 +1914,18 @@    plan0@(_, _, sharedConfig) <- planProject testdir1 config -  let isOSX (Platform _ OSX) = True-      isOSX _ = False-      compilerVer = compilerVersion (pkgConfigCompiler sharedConfig)+  let compilerVer = compilerVersion (pkgConfigCompiler sharedConfig)   -- Skip the Custom tests when the shipped Cabal library is buggy-  unless-    ( (isOSX (pkgConfigPlatform sharedConfig) && (compilerVer < mkVersion [7, 10]))-        -- 9.10 ships Cabal 3.12.0.0 affected by #9940-        || (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11])-    )-    $ do+  -- 9.10 ships Cabal 3.12.0.0 affected by #9940+  unless (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11]) $+    do       (plan1, res1) <- executePlan plan0       pkg1 <- expectPackageInstalled plan1 res1 pkgidA       elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps       hasDefaultSetupDeps pkg1 @?= Just False       marker1 <- readFile (basedir </> testdir1 </> "marker")       marker1 @?= "ok"-      removeFile (basedir </> testdir1 </> "marker")+      removeFileForcibly (basedir </> testdir1 </> "marker")        -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later       when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8, 2]) $ do@@ -1939,7 +1936,7 @@         hasDefaultSetupDeps pkg2 @?= Just True         marker2 <- readFile (basedir </> testdir2 </> "marker")         marker2 @?= "ok"-        removeFile (basedir </> testdir2 </> "marker")+        removeFileForcibly (basedir </> testdir2 </> "marker")        reportSubCase (show SetupNonCustomInternalLib)       (plan3, res3) <- executePlan =<< planProject testdir3 config@@ -2021,7 +2018,7 @@   -- add the missing dep, now it should work   let qcabal = basedir </> testdir </> "q" </> "q.cabal"   withFileFinallyRestore qcabal $ do-    tryFewTimes $ BS.appendFile qcabal ("  build-depends: p\n")+    tryFewTimes $ BS.appendFile qcabal "  build-depends: p\n"     (plan2, res2) <- executePlan =<< planProject testdir config     _ <- expectPackageInstalled plan2 res2 "p-0.1"     _ <- expectPackageInstalled plan2 res2 "q-0.1"@@ -2097,7 +2094,7 @@    assertEqual     "q"-    (Nothing)+    Nothing     (getProgArgs packages "q")   assertEqual     "p"@@ -2128,9 +2125,21 @@ getProgArgs [] _ = Nothing getProgArgs (elab : pkgs) name   | pkgName (elabPkgSourceId elab) == mkPackageName name =-      Map.lookup "ghc" (elabProgramArgs elab)+      removeHideAllPackages $ Map.lookup "ghc" (elabProgramArgs elab)   | otherwise =       getProgArgs pkgs name+  where+    removeHideAllPackages mbArgs =+      -- Filter out "-hide-all-packages", as we pass that by default+      -- to GHC invocations in order to avoid it picking up environment files.+      -- See https://github.com/haskell/cabal/issues/4010+      case filter (/= "-hide-all-packages") <$> mbArgs of+        Just args'+          | null args' ->+              Nothing+          | otherwise ->+              Just args'+        Nothing -> Nothing  --------------------------------- -- Test utils to plan and build@@ -2178,18 +2187,18 @@   -- ended in an exception (as we leave the files to help with debugging).   cleanProject testdir -  httpTransport <- configureTransport verbosity [] Nothing+  httpTransport <- configureTransport testVerbosity [] Nothing    (projectConfig, localPackages) <-     rebuildProjectConfig-      verbosity+      testVerbosity       httpTransport       distDirLayout       cliConfig    let buildSettings =         resolveBuildTimeSettings-          verbosity+          testVerbosity           cabalDirLayout           projectConfig @@ -2219,7 +2228,7 @@    (elaboratedPlan, _, elaboratedShared, _, _) <-     rebuildInstallPlan-      verbosity+      testVerbosity       distDirLayout       cabalDirLayout       projectConfig@@ -2267,7 +2276,7 @@      buildOutcomes <-       rebuildTargets-        verbosity+        testVerbosity         config         distDirLayout         (cabalStoreDirLayout cabalDirLayout)@@ -2280,16 +2289,14 @@     return (elaboratedPlan'', buildOutcomes)  cleanProject :: FilePath -> IO ()-cleanProject testdir = do-  alreadyExists <- doesDirectoryExist distDir-  when alreadyExists $ removePathForcibly distDir+cleanProject testdir = removePathForcibly distDir   where     projectRoot = ProjectRootImplicit (basedir </> testdir)     distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing     distDir = distDirectory distDirLayout -verbosity :: Verbosity-verbosity = minBound -- normal --verbose --maxBound --minBound+testVerbosity :: Verbosity+testVerbosity = mkVerbosity defaultVerbosityHandles silent  ------------------------------------------- -- Tasty integration to adjust the config@@ -2477,35 +2484,6 @@       threadDelay 10000       go (n - 1) -testNixFlags :: Assertion-testNixFlags = do-  let gc = globalCommand []-  -- changing from the v1 to v2 build command does not change whether the "--enable-nix" flag-  -- sets the globalNix param of the GlobalFlags type to True even though the v2 command doesn't use it-  let nixEnabledFlags = getFlags gc . commandParseArgs gc True $ ["--enable-nix", "build"]-  let nixDisabledFlags = getFlags gc . commandParseArgs gc True $ ["--disable-nix", "build"]-  let nixDefaultFlags = getFlags gc . commandParseArgs gc True $ ["build"]-  True @=? isJust nixDefaultFlags-  True @=? isJust nixEnabledFlags-  True @=? isJust nixDisabledFlags-  Just True @=? (fromFlag . globalNix . fromJust $ nixEnabledFlags)-  Just False @=? (fromFlag . globalNix . fromJust $ nixDisabledFlags)-  Nothing @=? (fromFlag . globalNix . fromJust $ nixDefaultFlags)--  -- Config file options-  trueConfig <- loadConfig verbosity (Flag (basedir </> "nix-config/nix-true"))-  falseConfig <- loadConfig verbosity (Flag (basedir </> "nix-config/nix-false"))--  Just True @=? (fromFlag . globalNix . savedGlobalFlags $ trueConfig)-  Just False @=? (fromFlag . globalNix . savedGlobalFlags $ falseConfig)-  where-    fromFlag :: Flag Bool -> Maybe Bool-    fromFlag (Flag x) = Just x-    fromFlag NoFlag = Nothing-    getFlags :: CommandUI GlobalFlags -> CommandParse (GlobalFlags -> GlobalFlags, [String]) -> Maybe GlobalFlags-    getFlags cui (CommandReadyToGo (mkflags, _)) = Just . mkflags . commandDefaultFlags $ cui-    getFlags _ _ = Nothing- -- Tests whether config options are commented or not testConfigOptionComments :: Assertion testConfigOptionComments = do@@ -2531,7 +2509,7 @@    cwd <- getCurrentDirectory   let configFile = cwd </> basedir </> "config" </> "default-config"-  _ <- createDefaultConfigFile verbosity [] configFile+  _ <- createDefaultConfigFile testVerbosity [] configFile   defaultConfigFile <- readFile configFile    let@@ -2573,7 +2551,6 @@    "-- ignore-expiry" `assertHasCommentLine` "ignore-expiry"   "-- http-transport" `assertHasCommentLine` "http-transport"-  "-- nix" `assertHasCommentLine` "nix"   "-- store-dir" `assertHasCommentLine` "store-dir"   "-- active-repositories" `assertHasCommentLine` "active-repositories"   "-- local-no-index-repo" `assertHasCommentLine` "local-no-index-repo"@@ -2675,7 +2652,6 @@   "-- username" `assertHasCommentLine` "username"   "-- password" `assertHasCommentLine` "password"   "-- password-command" `assertHasCommentLine` "password-command"-  "-- builddir" `assertHasCommentLine` "builddir"    "  -- hoogle" `assertHasCommentLine` "hoogle"   "  -- html" `assertHasCommentLine` "html"@@ -2769,7 +2745,8 @@  testIgnoreProjectFlag :: Assertion testIgnoreProjectFlag = do-  -- Coverage flag should be false globally by default (~/.cabal folder)+  -- Coverage flag should be false globally by default.+  -- This should be covered by the vanilla config file created in `main`.   (_, _, prjConfigGlobal, _, _) <- configureProject testdir ignoreSetConfig   let globalCoverageFlag = packageConfigCoverage . projectConfigLocalPackages $ prjConfigGlobal   False @=? Flag.fromFlagOrDefault False globalCoverageFlag@@ -2787,18 +2764,19 @@ cleanHaddockProject testdir = do   cleanProject testdir   let haddocksdir = basedir </> testdir </> "haddocks"-  alreadyExists <- doesDirectoryExist haddocksdir-  when alreadyExists $ removePathForcibly haddocksdir+  removePathForcibly haddocksdir   let storedir = basedir </> testdir </> "store"-  alreadyExists' <- doesDirectoryExist storedir-  when alreadyExists' $ removePathForcibly storedir+  removePathForcibly storedir  testHaddockProjectDependencies :: ProjectConfig -> Assertion testHaddockProjectDependencies config = do   (_, _, sharedConfig) <- planProject testdir config   -- `haddock-project` is only supported by `haddock-2.26.1` and above which is   -- shipped with `ghc-9.4`-  when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, 4]) $ do+  -- And doesn't work with older ghc on Windows for some reason (file in the+  -- wrong place, perhaps?).+  let safeMinor = if buildOS == Windows then 10 else 4+  when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, safeMinor]) $ do     let dir = basedir </> testdir     cleanHaddockProject testdir     withCurrentDirectory dir $ do@@ -2806,13 +2784,13 @@         defaultHaddockProjectFlags           { haddockProjectCommonFlags =               defaultCommonSetupFlags-                { setupVerbosity = Flag verbosity+                { setupVerbosity = Flag $ verbosityFlags testVerbosity                 }           }         ["all"]         defaultGlobalFlags{globalStoreDir = Flag "store"} -      let haddock = "haddocks" </> "async" </> "async.haddock"+      let haddock = "haddocks" </> "time" </> "time.haddock"       hasHaddock <- doesFileExist haddock       unless hasHaddock $ assertFailure ("File `" ++ haddock ++ "` does not exist.")     cleanHaddockProject testdir
− tests/IntegrationTests2/CPP.hs 
@@ -1,26 +0,0 @@-{- FOURMOLU_DISABLE -}-{-# LANGUAGE CPP #-}--module IntegrationTests2.CPP-  ( removePathForcibly-  , isMingw32-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--#if MIN_VERSION_directory(1,2,7)-import System.Directory (removePathForcibly)-#endif--#if !MIN_VERSION_directory(1,2,7)-removePathForcibly :: FilePath -> IO ()-removePathForcibly = removeDirectoryRecursive-#endif--isMingw32 :: Bool-#ifndef mingw32_HOST_OS-isMingw32 = True-#else-isMingw32 = False-#endif
tests/LongTests.hs view
@@ -2,10 +2,6 @@  import Test.Tasty -import Distribution.Compat.Time-import Distribution.Simple.Utils-import Distribution.Verbosity- import qualified UnitTests.Distribution.Client.Described import qualified UnitTests.Distribution.Client.FileMonitor import qualified UnitTests.Distribution.Client.VCS@@ -13,37 +9,22 @@ import UnitTests.Options  main :: IO ()-main = do-  (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay-  let toMillis :: Int -> Double-      toMillis x = fromIntegral x / 1000.0-  notice normal $-    "File modification time resolution calibration completed, "-      ++ "maximum delay observed: "-      ++ (show . toMillis $ mtimeChange)-      ++ " ms. "-      ++ "Will be using delay of "-      ++ (show . toMillis $ mtimeChange')-      ++ " for test runs."+main =   defaultMainWithIngredients     (includingOptions extraOptions : defaultIngredients)-    (tests mtimeChange')+    tests -tests :: Int -> TestTree-tests mtimeChangeCalibrated =-  askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->-    let mtimeChange =-          if mtimeChangeProvided /= 0-            then mtimeChangeProvided-            else mtimeChangeCalibrated-     in testGroup-          "Long-running tests"-          [ testGroup-              "Solver QuickCheck"-              UnitTests.Distribution.Solver.Modular.QuickCheck.tests-          , testGroup "UnitTests.Distribution.Client.VCS" $-              UnitTests.Distribution.Client.VCS.tests mtimeChange-          , testGroup "UnitTests.Distribution.Client.FileMonitor" $-              UnitTests.Distribution.Client.FileMonitor.tests mtimeChange-          , UnitTests.Distribution.Client.Described.tests-          ]+tests :: TestTree+tests =+  askOption $ \(OptionMtimeChangeDelay mtimeChange) ->+    testGroup+      "Long-running tests"+      [ testGroup+          "Solver QuickCheck"+          UnitTests.Distribution.Solver.Modular.QuickCheck.tests+      , testGroup "UnitTests.Distribution.Client.VCS" $+          UnitTests.Distribution.Client.VCS.tests mtimeChange+      , testGroup "UnitTests.Distribution.Client.FileMonitor" $+          UnitTests.Distribution.Client.FileMonitor.tests mtimeChange+      , UnitTests.Distribution.Client.Described.tests+      ]
tests/UnitTests.hs view
@@ -9,6 +9,7 @@ import qualified UnitTests.Distribution.Client.Get import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.IndexUtils+import qualified UnitTests.Distribution.Client.IndexUtils.ActiveRepos import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp import qualified UnitTests.Distribution.Client.Init import qualified UnitTests.Distribution.Client.InstallPlan@@ -52,6 +53,9 @@       , testGroup           "UnitTests.Distribution.Client.IndexUtils"           UnitTests.Distribution.Client.IndexUtils.tests+      , testGroup+          "UnitTests.Distribution.Client.IndexUtils.ActiveRepos"+          UnitTests.Distribution.Client.IndexUtils.ActiveRepos.tests       , testGroup           "UnitTests.Distribution.Client.IndexUtils.Timestamp"           UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
tests/UnitTests/Distribution/Client/ArbitraryInstances.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-}  module UnitTests.Distribution.Client.ArbitraryInstances@@ -111,8 +112,7 @@  instance Arbitrary URIAuth where   arbitrary =-    URIAuth-      <$> pure "" -- no password as this does not roundtrip+    pure (URIAuth "") -- no password as this does not roundtrip       <*> arbitraryURIToken       <*> arbitraryURIPort @@ -150,7 +150,7 @@   arbitrary =     ShortToken       <$> ( shortListOf1 5 (choose ('#', '~'))-              `suchThat` (all (`notElem` "{}"))+              `suchThat` all (`notElem` "{}")               `suchThat` (not . ("[]" `isPrefixOf`))           ) @@ -320,7 +320,7 @@   arbitrary = do     x1 <- arbitrary     x2 <- arbitrary-    return $ optStanzaTabulate $ \x -> case x of+    return $ optStanzaTabulate $ \case       TestStanzas -> x1       BenchStanzas -> x2 @@ -387,9 +387,8 @@       take         (max 1 sz)         [ pure GlobDirTrailing-        , GlobFile <$> (getGlobPieces <$> arbitrary)-        , GlobDir-            <$> (getGlobPieces <$> arbitrary)+        , GlobFile . getGlobPieces <$> arbitrary+        , (GlobDir . getGlobPieces <$> arbitrary)             <*> resize (sz `div` 2) arbitrary         ] @@ -421,6 +420,11 @@ mergeLiterals :: [GlobPiece] -> [GlobPiece] mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps) mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps+-- Two consecutive wildcards are semantically equivalent to a single one, but+-- would syntactically produce a recursive wildcard when pretty-printed, so+-- whenever we end up generating two or more consecutive wildcards, we merge+-- them together to avoid this problem.+mergeLiterals (WildCard : WildCard : ps) = mergeLiterals (WildCard : ps) mergeLiterals (p : ps) = p : mergeLiterals ps mergeLiterals [] = []
tests/UnitTests/Distribution/Client/Configure.hs view
@@ -4,7 +4,6 @@  import Distribution.Client.CmdConfigure -import Control.Monad import qualified Data.Map as Map import Distribution.Client.NixStyleOptions import Distribution.Client.ProjectConfig.Types@@ -12,6 +11,7 @@ import Distribution.Client.Setup import Distribution.Simple import Distribution.Simple.Flag+import Distribution.Simple.Utils (removeFileForcibly) import Distribution.Verbosity import System.Directory import System.FilePath@@ -109,9 +109,7 @@                 }             backup = projectDir </> "cabal.project.local~" -        exists <- doesFileExist backup-        when exists $-          removeFile backup+        removeFileForcibly backup          _ <- configureAction' flags [] defaultGlobalFlags
tests/UnitTests/Distribution/Client/DescribedInstances.hs view
@@ -92,7 +92,7 @@  instance Described RelaxedDep where   describe _ =-    REOpt (describeRelaxDepScope <> ":" <> REOpt ("^"))+    REOpt (describeRelaxDepScope <> ":" <> REOpt "^")       <> describe (Proxy :: Proxy RelaxDepSubject)     where       describeRelaxDepScope =
tests/UnitTests/Distribution/Client/FetchUtils.hs view
@@ -30,15 +30,15 @@       [ testCase "handles an empty package list" testEmpty       , testCase "passes an unpacked local package through" testPassLocalPackage       , testCase "handles http" testHttp-      , testCase "aborts on interrupt in GET" $ testGetInterrupt-      , testCase "aborts on other exception in GET" $ testGetException-      , testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt-      , testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException+      , testCase "aborts on interrupt in GET" testGetInterrupt+      , testCase "aborts on other exception in GET" testGetException+      , testCase "aborts on interrupt in GET (uncollected download)" testUncollectedInterrupt+      , testCase "continues on other exception in GET (uncollected download)" testUncollectedException       ]   ]  verbosity :: Verbosity.Verbosity-verbosity = Verbosity.silent+verbosity = Verbosity.mkVerbosity Verbosity.defaultVerbosityHandles Verbosity.silent  -- | An interval that we use to assert that something happens "immediately". -- Must be shorter than 'longSleep' to ensure those are interrupted.
tests/UnitTests/Distribution/Client/FileMonitor.hs view
@@ -13,9 +13,8 @@ import qualified Prelude as IO (writeFile)  import Distribution.Compat.Binary-import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Simple.Utils (removeFileForcibly, withTempDirectory) import Distribution.System (OS (Windows), buildOS)-import Distribution.Verbosity (silent)  import Distribution.Client.FileMonitor import Distribution.Compat.Time@@ -54,11 +53,21 @@       , testCase "remove match" $ testGlobRemoveMatch mtimeChange       , testCase "change match" $ testGlobChangeMatch mtimeChange       , testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange+      , testCase "add match subdir, recursive glob" $ testRecursiveGlobAddMatchSubdir mtimeChange+      , testCase "add match sub-subdir, recursive glob" $ testRecursiveGlobAddMatchSubSubdir mtimeChange+      , testCase "add match new sub-subdir, recursive glob" $ testRecursiveGlobAddMatchNewSubSubdir mtimeChange+      , testCase "add match new deep sub-subdir, recursive glob" $ testRecursiveGlobAddMatchNewDeepSubSubdir mtimeChange+      , testCase "move subdir, recursive glob" $ testRecursiveGlobMoveSubdir mtimeChange+      , testCase "move matching dir, recursive glob" $ testRecursiveGlobMoveMatchingDir mtimeChange       , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange+      , testCase "remove match subdir, recursive glob" $ testRecursiveGlobRemoveMatchSubdir mtimeChange+      , testCase "remove match sub-subdir, recursive glob" $ testRecursiveGlobRemoveMatchSubSubdir mtimeChange       , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange+      , testCase "change match subdir, recursive glob" $ testRecursiveGlobChangeMatchSubdir mtimeChange       , testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange       , testCase "add non-match" $ testGlobAddNonMatch mtimeChange       , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange+      , testCase "remove non-match, recursive glob" $ testRecursiveGlobRemoveNonMatch mtimeChange       , knownBrokenInWindows "See issue #3126" $           testCase "add non-match subdir" $             testGlobAddNonMatchSubdir mtimeChange@@ -86,17 +95,17 @@       Windows -> expectFailBecause msg       _ -> id     fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64-    fingerprintStateGlob1 = 0x1f9edda22b7e8de6-    fingerprintStateGlob2 = 0xda1d085c9fc6f5db-    fingerprintStateFileSet1 = 0x00ac4a0df546905d-    fingerprintStateFileSet2 = 0x5b2b2df018b1fa83+    fingerprintStateGlob1 = 0x5d9efec2b93d22a1+    fingerprintStateGlob2 = 0xfdbc86351866a191+    fingerprintStateFileSet1 = 0x4cee0a3a23697bb1+    fingerprintStateFileSet2 = 0x96039d15c3241985  -- Check the file system behaves the way we expect it to  -- we rely on file mtimes having a reasonable resolution testFileMTimeSanity :: Int -> Assertion testFileMTimeSanity mtimeChange =-  withTempDirectory silent "." "file-status-" $ \dir -> do+  withTempDirectory "." "file-status-" $ \dir -> do     replicateM_ 10 $ do       IO.writeFile (dir </> "a") "content"       t1 <- getModTime (dir </> "a")@@ -108,7 +117,7 @@ -- We rely on directories changing mtime when entries are added or removed testDirChangeSanity :: Int -> Assertion testDirChangeSanity mtimeChange =-  withTempDirectory silent "." "dir-mtime-" $ \dir -> do+  withTempDirectory "." "dir-mtime-" $ \dir -> do     expectMTimeChange dir "file add" $       IO.writeFile (dir </> "file") "content" @@ -517,6 +526,69 @@     reason <- expectMonitorChanged root monitor ()     reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b") +testRecursiveGlobAddMatchSubdir :: Int -> Assertion+testRecursiveGlobAddMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++testRecursiveGlobAddMatchSubSubdir :: Int -> Assertion+testRecursiveGlobAddMatchSubSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "a" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "a" </> "b" </> "good-c")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "b" </> "good-c")++testRecursiveGlobAddMatchNewSubSubdir :: Int -> Assertion+testRecursiveGlobAddMatchNewSubSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "a" </> "b" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "b" </> "good-b")++testRecursiveGlobAddMatchNewDeepSubSubdir :: Int -> Assertion+testRecursiveGlobAddMatchNewDeepSubSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "b" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "c" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "c" </> "good-b")++testRecursiveGlobMoveSubdir :: Int -> Assertion+testRecursiveGlobMoveSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "b" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "b" </> "good-a")+    removeFile root ("dir" </> "a" </> "b" </> "good-a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "b" </> "good-a")++testRecursiveGlobMoveMatchingDir :: Int -> Assertion+testRecursiveGlobMoveMatchingDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    removeDir root "dir"+    touchFile root ("dir2" </> "a" </> "good-a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a")+ testGlobRemoveMatchSubdir :: Int -> Assertion testGlobRemoveMatchSubdir mtimeChange =   withFileMonitor $ \root monitor -> do@@ -528,6 +600,28 @@     reason <- expectMonitorChanged root monitor ()     reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a") +testRecursiveGlobRemoveMatchSubdir :: Int -> Assertion+testRecursiveGlobRemoveMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "a" </> "good-a")++testRecursiveGlobRemoveMatchSubSubdir :: Int -> Assertion+testRecursiveGlobRemoveMatchSubSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "a" </> "good-a")+    touchFile root ("dir" </> "a" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "a" </> "good-a")+ testGlobChangeMatchSubdir :: Int -> Assertion testGlobChangeMatchSubdir mtimeChange =   withFileMonitor $ \root monitor -> do@@ -544,6 +638,22 @@     reason <- expectMonitorChanged root monitor ()     reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b") +testRecursiveGlobChangeMatchSubdir :: Int -> Assertion+testRecursiveGlobChangeMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "c" </> "good-a")+    touchFile root ("dir" </> "b" </> "c" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "c" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res @?= ()+    files @?= [monitorFileGlobStr "dir/**/good-*"]++    touchFileContent root "dir/b/c/good-b"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "c" </> "good-b")+ -- check nothing goes squiffy with matching in the top dir testGlobMatchTopDir :: Int -> Assertion testGlobMatchTopDir mtimeChange =@@ -577,6 +687,18 @@     res @?= ()     files @?= [monitorFileGlobStr "dir/good-*"] +testRecursiveGlobRemoveNonMatch :: Int -> Assertion+testRecursiveGlobRemoveNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/b/bad"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res @?= ()+    files @?= [monitorFileGlobStr "dir/**/good-*"]+ testGlobAddNonMatchSubdir :: Int -> Assertion testGlobAddNonMatchSubdir mtimeChange =   withFileMonitor $ \root monitor -> do@@ -714,8 +836,8 @@   withFileMonitor $ \root monitor -> do     root' <- absoluteRoot root     -- absolute glob, removing a file-    touchFile root ("dir/good-a")-    touchFile root ("dir/good-b")+    touchFile root "dir/good-a"+    touchFile root "dir/good-b"     updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()     threadDelay mtimeChange     removeFile root "dir/good-a"@@ -724,7 +846,7 @@     -- absolute glob, adding a file     updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()     threadDelay mtimeChange-    touchFile root ("dir/good-a")+    touchFile root "dir/good-a"     reason2 <- expectMonitorChanged root monitor ()     reason2 @?= MonitoredFileChanged (root' </> "dir" </> "good-a")     -- absolute glob, changing a file@@ -819,7 +941,7 @@   IO.writeFile path "different"  removeFile :: RootPath -> FilePath -> IO ()-removeFile (RootPath root) fname = IO.removeFile (root </> fname)+removeFile (RootPath root) fname = removeFileForcibly (root </> fname)  touchDir :: RootPath -> FilePath -> IO () touchDir root@(RootPath rootdir) dname = do@@ -834,7 +956,7 @@   IO.createDirectory path  removeDir :: RootPath -> FilePath -> IO ()-removeDir (RootPath root) dname = IO.removeDirectoryRecursive (root </> dname)+removeDir (RootPath root) dname = IO.removePathForcibly (root </> dname)  absoluteRoot :: RootPath -> IO FilePath absoluteRoot (RootPath root) = IO.canonicalizePath root@@ -902,9 +1024,8 @@  withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c withFileMonitor action = do-  withTempDirectory silent "." "file-status-" $ \root -> do+  withTempDirectory "." "file-status-" $ \root -> do     let file = root <.> "monitor"         monitor = newFileMonitor file     finally (action (RootPath root) monitor) $ do-      exists <- IO.doesFileExist file-      when exists $ IO.removeFile file+      removeFileForcibly file
tests/UnitTests/Distribution/Client/GZipUtils.hs view
@@ -11,6 +11,7 @@ import Data.ByteString as BS (null) import Data.ByteString.Lazy as BSL (pack, toChunks) import Data.ByteString.Lazy.Char8 as BSLL (init, length, pack)+import Data.Either (isLeft) import Distribution.Client.GZipUtils (maybeDecompress)  import Test.Tasty@@ -55,8 +56,3 @@   where     original = BSL.pack ws     compressedGZip = GZip.compress original---- (Only available from "Data.Either" since 7.8.)-isLeft :: Either a b -> Bool-isLeft (Right _) = False-isLeft (Left _) = True
tests/UnitTests/Distribution/Client/Get.hs view
@@ -40,7 +40,8 @@       ]   , askOption $ \(RunNetworkTests doRunNetTests) ->       testGroup "forkPackages, network tests" $-        includeTestsIf doRunNetTests $+        includeTestsIf+          doRunNetTests           [ testCase "git clone" testNetworkGitClone           ]   ]@@ -49,7 +50,7 @@     includeTestsIf False _ = []  verbosity :: Verbosity-verbosity = Verbosity.silent -- for debugging try verbose+verbosity = Verbosity.mkVerbosity Verbosity.defaultVerbosityHandles Verbosity.silent -- for debugging try verbose  pkgidfoo :: PackageId pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0])@@ -261,7 +262,7 @@     Right _ ->       assertFailure $         "expected exception of type "-          ++ show (typeOf (undefined :: e))+          ++ show (typeRep (Proxy :: Proxy e))  -- | Expect that one line in a file matches exactly the given words (i.e. at -- least insensitive to whitespace)
tests/UnitTests/Distribution/Client/Glob.hs view
@@ -48,6 +48,19 @@    RootedGlob     FilePathRelative+    (GlobDirRecursive [WildCard]) <-+    testparse "**/*"+  RootedGlob+    FilePathRelative+    (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard])) <-+    testparse "foo/**/*"+  RootedGlob+    FilePathRelative+    (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard, Literal ".txt"])) <-+    testparse "foo/**/*.txt"++  RootedGlob+    FilePathRelative     (GlobFile [Literal "."]) <-     testparse "." @@ -106,7 +119,7 @@   RootedGlob     FilePathRelative     (GlobFile [WildCard, WildCard]) <--    testparse "**" -- not helpful but valid+    testparse "**" -- not helpful, but valid (?)   RootedGlob     FilePathRelative     (GlobFile [WildCard, Literal "foo", WildCard]) <-
tests/UnitTests/Distribution/Client/IndexUtils.hs view
@@ -1,21 +1,34 @@ module UnitTests.Distribution.Client.IndexUtils where  import Distribution.Client.IndexUtils+import Distribution.Client.IndexUtils.ActiveRepos import qualified Distribution.Compat.NonEmptySet as NES+import Distribution.Package import Distribution.Simple.Utils (toUTF8LBS)-import Distribution.Types.Dependency+import Distribution.Solver.Types.PackageIndex (OverrideOrMerge (..))+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Types.LibraryName-import Distribution.Types.PackageName import Distribution.Version +import qualified Data.List as List+import qualified Data.Map.Strict as Map+ import Test.Tasty import Test.Tasty.HUnit  tests :: [TestTree] tests =   [ simpleVersionsParserTests+  , indexCombiningTests+  , overrideOrMergeTests+  , deprecationAwareStrategyTests+  , addIndexTests   ] +-- ---------------------------------------------------------------------------+-- Preferred-versions parser tests+-- ---------------------------------------------------------------------------+ simpleVersionsParserTests :: TestTree simpleVersionsParserTests =   testGroup@@ -80,3 +93,288 @@               ]         , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0"         }++-- ---------------------------------------------------------------------------+-- Index-combining tests+--+-- These test 'applyStrategy' (exported from IndexUtils), which is the+-- per-repository step used by getSourcePackagesAtIndexState:+--+--   applyStrategy acc (_, Skip)     = acc+--   applyStrategy acc (idx, Merge)  = PackageIndex.merge acc idx+--   applyStrategy acc (idx, Override) = PackageIndex.override acc idx+--   pkgs = foldl' (\acc (rd, s) -> applyStrategy acc (rdIndex rd, s)) mempty pkgss'+-- ---------------------------------------------------------------------------++indexCombiningTests :: TestTree+indexCombiningTests =+  testGroup+    "Index combining (CombineStrategy)"+    [ testCase "Skip: repo contributes nothing" $+        pkgs [(repoFoo1, CombineStrategySkip)]+          @?= []+    , testCase "Merge: single repo makes all its packages visible" $+        pkgs [(repoFoo1, CombineStrategyMerge)]+          @?= [foo1]+    , testCase "Override: single repo makes all its packages visible" $+        pkgs [(repoFoo1, CombineStrategyOverride)]+          @?= [foo1]+    , testCase "Merge+Merge: non-overlapping packages are both visible" $+        pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyMerge)]+          @?= List.sort [foo1, bar1]+    , testCase "Merge+Merge: different versions of same package are both visible" $+        pkgs [(repoFoo1, CombineStrategyMerge), (repoFoo2, CombineStrategyMerge)]+          @?= List.sort [foo1, foo2]+    , testCase "Merge+Override: packages only in first repo remain visible" $+        pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyOverride)]+          @?= List.sort [foo1, bar1]+    , testCase "Merge+Override: override repo replaces all versions of overlapping package" $+        -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0.+        -- Override means repoFoo2 wins the entire 'foo' bucket.+        pkgs [(repoFoo12, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)]+          @?= [foo2]+    , testCase "Merge+Override: override does not affect packages absent from override repo" $+        pkgs [(repoFoo1bar1, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)]+          @?= List.sort [foo2, bar1]+    , testCase "Skip in middle: skipped repo is ignored" $+        pkgs+          [ (repoFoo1, CombineStrategyMerge)+          , (repoFoo2, CombineStrategySkip)+          , (repoBar1, CombineStrategyMerge)+          ]+          @?= List.sort [foo1, bar1]+    , testCase "Skip+Merge: later merge after skip still contributes" $+        pkgs [(repoFoo1, CombineStrategySkip), (repoFoo2, CombineStrategyMerge)]+          @?= [foo2]+    , testCase "Override+Override: last override wins the package bucket" $+        pkgs+          [ (repoFoo1, CombineStrategyMerge)+          , (repoFoo2, CombineStrategyOverride)+          , (repoFoo3, CombineStrategyOverride)+          ]+          @?= [foo3]+    , testCase "Override+Merge: merge after override combines both buckets" $+        -- foo bucket starts as {foo-2.0} after override, then merges {foo-3.0}+        -- giving {foo-2.0, foo-3.0}+        pkgs+          [ (repoFoo1, CombineStrategyMerge)+          , (repoFoo2, CombineStrategyOverride)+          , (repoFoo3, CombineStrategyMerge)+          ]+          @?= List.sort [foo2, foo3]+    , testCase "All skip: result is empty" $+        pkgs+          [ (repoFoo1, CombineStrategySkip)+          , (repoFoo2, CombineStrategySkip)+          ]+          @?= []+    , testCase "Empty repos list: result is empty" $+        pkgs [] @?= []+    ]++-- Run the combining fold and return the result as a sorted list of PackageIds.+-- Uses the exported 'applyStrategy' from IndexUtils directly, so this stays+-- in sync with the production implementation in getSourcePackagesAtIndexState.+pkgs+  :: [(PackageIndex.PackageIndex PackageIdentifier, CombineStrategy)]+  -> [PackageIdentifier]+pkgs = List.sort . PackageIndex.allPackages . List.foldl' applyStrategy mempty++-- Test packages+foo1, foo2, foo3, bar1 :: PackageIdentifier+foo1 = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0])+foo2 = PackageIdentifier (mkPackageName "foo") (mkVersion [2, 0])+foo3 = PackageIdentifier (mkPackageName "foo") (mkVersion [3, 0])+bar1 = PackageIdentifier (mkPackageName "bar") (mkVersion [1, 0])++-- Single-package indices+repoFoo1, repoFoo2, repoFoo3, repoBar1 :: PackageIndex.PackageIndex PackageIdentifier+repoFoo1 = PackageIndex.fromList [foo1]+repoFoo2 = PackageIndex.fromList [foo2]+repoFoo3 = PackageIndex.fromList [foo3]+repoBar1 = PackageIndex.fromList [bar1]++-- Multi-package indices+repoFoo12, repoFoo1bar1 :: PackageIndex.PackageIndex PackageIdentifier+repoFoo12 = PackageIndex.fromList [foo1, foo2]+repoFoo1bar1 = PackageIndex.fromList [foo1, bar1]++-- ---------------------------------------------------------------------------+-- overrideOrMerge tests+--+-- These test PackageIndex.overrideOrMerge directly, which is the building+-- block for conditionally falling back to merge when all versions of a+-- package in the override repo are deprecated (issue #8502).+-- ---------------------------------------------------------------------------++overrideOrMergeTests :: TestTree+overrideOrMergeTests =+  testGroup+    "overrideOrMerge"+    [ testCase "all-Override strategy matches plain override" $+        -- When strategy always returns Override, result equals PackageIndex.override+        let result = PackageIndex.overrideOrMerge (const Override) repoFoo12 repoFoo2+            expected = PackageIndex.override repoFoo12 repoFoo2+         in allPkgs result @?= allPkgs expected+    , testCase "all-Merge strategy matches plain merge" $+        -- When strategy always returns Merge, result equals PackageIndex.merge+        let result = PackageIndex.overrideOrMerge (const Merge) repoFoo12 repoFoo2+            expected = PackageIndex.merge repoFoo12 repoFoo2+         in allPkgs result @?= allPkgs expected+    , testCase "Override: second index wins entire package bucket" $+        -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0.+        -- Override means repoFoo2 wins the 'foo' bucket, so foo-1.0 is hidden.+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo12 repoFoo2)+          @?= [foo2]+    , testCase "Merge: both buckets combined, duplicates removed" $+        -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0.+        -- Merge keeps foo-1.0 and foo-2.0 (foo-2.0 deduplicated).+        allPkgs (PackageIndex.overrideOrMerge (const Merge) repoFoo12 repoFoo2)+          @?= List.sort [foo1, foo2]+    , testCase "mixed strategy: Override for foo, Merge for bar" $+        -- repoFoo1bar1 has foo-1.0 and bar-1.0; second index has foo-2.0 and bar-1.0.+        -- foo is overridden (foo-1.0 hidden), bar is merged (bar-1.0 deduplicated).+        let i2 = PackageIndex.fromList [foo2, bar1]+            strategy name+              | name == mkPackageName "foo" = Override+              | otherwise = Merge+         in allPkgs (PackageIndex.overrideOrMerge strategy repoFoo1bar1 i2)+              @?= List.sort [foo2, bar1]+    , testCase "deprecated fallback: Merge when override repo has only deprecated versions" $+        -- Simulates the issue-8502 scenario: repo-a has foo-1.0; repo-b (override)+        -- has foo-2.0 but all its versions are deprecated.  The caller detects this+        -- and passes Merge for 'foo', so foo-1.0 remains visible alongside foo-2.0.+        let repoA = PackageIndex.fromList [foo1]+            repoB = PackageIndex.fromList [foo2] -- pretend all deprecated+            strategy name+              | name == mkPackageName "foo" = Merge -- fall back because all deprecated+              | otherwise = Override+         in allPkgs (PackageIndex.overrideOrMerge strategy repoA repoB)+              @?= List.sort [foo1, foo2]+    , testCase "package absent from second index: first index versions kept" $+        -- bar is only in repoFoo1bar1, not in repoFoo2; it survives regardless of strategy.+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo1bar1 repoFoo2)+          @?= List.sort [foo2, bar1]+    , testCase "package absent from first index: second index versions appear" $+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo1 repoBar1)+          @?= List.sort [foo1, bar1]+    , testCase "empty first index: second index fully visible" $+        allPkgs (PackageIndex.overrideOrMerge (const Override) mempty repoFoo12)+          @?= List.sort [foo1, foo2]+    , testCase "empty second index: first index unchanged" $+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo12 mempty)+          @?= List.sort [foo1, foo2]+    ]++allPkgs :: PackageIndex.PackageIndex PackageIdentifier -> [PackageIdentifier]+allPkgs = List.sort . PackageIndex.allPackages++-- ---------------------------------------------------------------------------+-- deprecationAwareStrategy tests+--+-- Tests for the per-package Override/Merge decision used when applying a+-- CombineStrategyOverride repo.  The three cases are:+--   1. Package absent from preferred-versions  -> Override+--   2. Package present, some versions preferred -> Override+--   3. Package present, no versions preferred  -> Merge (all deprecated)+-- ---------------------------------------------------------------------------++deprecationAwareStrategyTests :: TestTree+deprecationAwareStrategyTests =+  testGroup+    "deprecationAwareStrategy"+    [ testCase "package absent from preferred-versions gives Override" $+        -- No entry for 'foo' in prefs, so the repo is not restricting it.+        strat repoFoo1 Map.empty fooName @?= Override+    , testCase "package present with matching versions gives Override" $+        -- foo-1.0 is in the index and satisfies ">= 1.0", so not all deprecated.+        strat repoFoo1 (prefs fooName (orLaterVersion v1)) fooName @?= Override+    , testCase "package present but no versions match gives Merge" $+        -- foo-1.0 is in the index but the pref ">= 2.0" excludes it: all deprecated.+        strat repoFoo1 (prefs fooName (orLaterVersion v2)) fooName @?= Merge+    , testCase "unrelated package in prefs does not affect result" $+        -- Prefs only mention 'bar'; 'foo' has no pref entry, so Override.+        strat repoFoo1 (prefs barName (orLaterVersion v1)) fooName @?= Override+    , testCase "package absent from index but in prefs gives Merge" $+        -- The pref entry exists but the index is empty, so lookupDependency+        -- returns [], meaning no preferred version exists.+        strat mempty (prefs fooName (orLaterVersion v2)) fooName @?= Merge+    , testCase "multiple packages decided independently" $+        -- foo is deprecated (pref excludes foo-1.0), bar is not (bar-1.0 satisfies >= 1.0).+        let p =+              Map.unionWith+                intersectVersionRanges+                (prefs fooName (orLaterVersion v2))+                (prefs barName (orLaterVersion v1))+         in do+              strat repoFoo1bar1 p fooName @?= Merge+              strat repoFoo1bar1 p barName @?= Override+    ]+  where+    strat = deprecationAwareStrategy+    fooName = mkPackageName "foo"+    barName = mkPackageName "bar"+    v1 = mkVersion [1, 0]+    v2 = mkVersion [2, 0]+    prefs name vr = Map.singleton name vr++-- ---------------------------------------------------------------------------+-- addIndex tests+--+-- Tests for the top-level addIndex, which is the function used by+-- getSourcePackagesAtIndexState to fold each repository's index into the+-- accumulator.  Unlike applyStrategy, addIndex consults preferred-versions+-- for CombineStrategyOverride, falling back to merge when all versions of a+-- package are deprecated.  A regression to plain override would cause the+-- "all deprecated" test to fail.+-- ---------------------------------------------------------------------------++addIndexTests :: TestTree+addIndexTests =+  testGroup+    "addIndex"+    [ testCase "Skip: index not added" $+        run [(repoFoo1, [], CombineStrategySkip)]+          @?= []+    , testCase "Merge: index added" $+        run [(repoFoo1, [], CombineStrategyMerge)]+          @?= [foo1]+    , testCase "Override with no prefs: behaves like plain override" $+        run+          [ (repoFoo12, [], CombineStrategyMerge)+          , (repoFoo2, [], CombineStrategyOverride)+          ]+          @?= [foo2]+    , testCase "Override with prefs matching some versions: still overrides" $+        -- foo-2.0 satisfies ">= 2.0", so not all deprecated; override applies.+        run+          [ (repoFoo12, [], CombineStrategyMerge)+          , (repoFoo2, [dep fooName (orLaterVersion v2)], CombineStrategyOverride)+          ]+          @?= [foo2]+    , testCase "Override with all versions deprecated: falls back to merge" $+        -- foo-2.0 does not satisfy ">= 3.0", so all versions deprecated;+        -- override falls back to merge, keeping foo-1.0 from the first repo.+        run+          [ (repoFoo1, [], CombineStrategyMerge)+          , (repoFoo2, [dep fooName (orLaterVersion v3)], CombineStrategyOverride)+          ]+          @?= List.sort [foo1, foo2]+    , testCase "Override: only the deprecated package falls back, others still override" $+        -- foo is all-deprecated in override repo → merge; bar has no prefs → override.+        run+          [ (repoFoo1bar1, [], CombineStrategyMerge)+          ,+            ( PackageIndex.fromList [foo2, bar1]+            , [dep fooName (orLaterVersion v3)]+            , CombineStrategyOverride+            )+          ]+          @?= List.sort [foo1, foo2, bar1]+    ]+  where+    run = allPkgs . List.foldl' (\acc (idx, ps, s) -> addIndex acc (idx, ps, s)) mempty+    fooName = mkPackageName "foo"+    v2 = mkVersion [2, 0]+    v3 = mkVersion [3, 0]+    dep name vr = Dependency name vr (NES.singleton LMainLibName)
+ tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs view
@@ -0,0 +1,169 @@+module UnitTests.Distribution.Client.IndexUtils.ActiveRepos (tests) where++import Distribution.Client.IndexUtils.ActiveRepos+import Distribution.Client.Types.RepoName (RepoName (..))+import Distribution.Parsec (simpleParsec)+import Distribution.Pretty (prettyShow)++import UnitTests.Distribution.Client.ArbitraryInstances ()++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+  [ testGroup "organizeByRepos" organizeByReposTests+  , testGroup "filterSkippedActiveRepos" filterSkippedTests+  , testGroup+      "parse/pretty roundtrip"+      [ testProperty "ActiveRepos roundtrips" prop_activeReposRoundtrip+      ]+  ]++-------------------------------------------------------------------------------+-- organizeByRepos+-------------------------------------------------------------------------------++-- Convenience: run organizeByRepos over a fixed three-element repo list.+organize :: ActiveRepos -> Either String [(RepoName, CombineStrategy)]+organize ar = organizeByRepos ar id [RepoName "a", RepoName "b", RepoName "c"]++organizeByReposTests :: [TestTree]+organizeByReposTests =+  [ testCase ":rest assigns strategy to all repos in order" $+      organize (ActiveRepos [ActiveRepoRest CombineStrategyMerge])+        @?= Right+          [ (RepoName "a", CombineStrategyMerge)+          , (RepoName "b", CombineStrategyMerge)+          , (RepoName "c", CombineStrategyMerge)+          ]+  , testCase ":none yields empty result" $+      organize (ActiveRepos [])+        @?= Right []+  , testCase "named repo before :rest is placed first" $+      organize+        ( ActiveRepos+            [ ActiveRepo (RepoName "b") CombineStrategyOverride+            , ActiveRepoRest CombineStrategyMerge+            ]+        )+        @?= Right+          [ (RepoName "b", CombineStrategyOverride)+          , (RepoName "a", CombineStrategyMerge)+          , (RepoName "c", CombineStrategyMerge)+          ]+  , testCase "named repo after :rest is placed last" $+      organize+        ( ActiveRepos+            [ ActiveRepoRest CombineStrategyMerge+            , ActiveRepo (RepoName "b") CombineStrategyOverride+            ]+        )+        @?= Right+          [ (RepoName "a", CombineStrategyMerge)+          , (RepoName "c", CombineStrategyMerge)+          , (RepoName "b", CombineStrategyOverride)+          ]+  , testCase "named repo absent from provided list gives Left" $+      organize+        ( ActiveRepos+            [ ActiveRepoRest CombineStrategyMerge+            , ActiveRepo (RepoName "d") CombineStrategyOverride+            ]+        )+        @?= Left "no repository provided d"+  , testCase "named repo against empty list gives Left" $+      organizeByRepos+        (ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge])+        id+        ([] :: [RepoName])+        @?= Left "no repository provided a"+  , testCase "skip strategy is preserved in output" $+      organize+        ( ActiveRepos+            [ ActiveRepo (RepoName "a") CombineStrategySkip+            , ActiveRepoRest CombineStrategyMerge+            ]+        )+        @?= Right+          [ (RepoName "a", CombineStrategySkip)+          , (RepoName "b", CombineStrategyMerge)+          , (RepoName "c", CombineStrategyMerge)+          ]+  , testCase ":rest with skip strategy skips all remaining repos" $+      organize (ActiveRepos [ActiveRepoRest CombineStrategySkip])+        @?= Right+          [ (RepoName "a", CombineStrategySkip)+          , (RepoName "b", CombineStrategySkip)+          , (RepoName "c", CombineStrategySkip)+          ]+  , testCase "multiple :rest entries cause each repo to appear once per :rest" $+      -- Documented edge case: if ActiveRepoRest appears more than once,+      -- the rest-repositories appear multiple times in the output.+      organize+        ( ActiveRepos+            [ ActiveRepoRest CombineStrategyMerge+            , ActiveRepoRest CombineStrategyOverride+            ]+        )+        @?= Right+          [ (RepoName "a", CombineStrategyMerge)+          , (RepoName "b", CombineStrategyMerge)+          , (RepoName "c", CombineStrategyMerge)+          , (RepoName "a", CombineStrategyOverride)+          , (RepoName "b", CombineStrategyOverride)+          , (RepoName "c", CombineStrategyOverride)+          ]+  ]++-------------------------------------------------------------------------------+-- filterSkippedActiveRepos+-------------------------------------------------------------------------------++filterSkippedTests :: [TestTree]+filterSkippedTests =+  [ testCase "skipped entries are removed when no :rest is present" $+      filterSkippedActiveRepos+        ( ActiveRepos+            [ ActiveRepo (RepoName "a") CombineStrategyMerge+            , ActiveRepo (RepoName "b") CombineStrategySkip+            ]+        )+        @?= ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge]+  , testCase "all-skipped list with no :rest yields empty" $+      filterSkippedActiveRepos+        ( ActiveRepos+            [ ActiveRepo (RepoName "a") CombineStrategySkip+            , ActiveRepo (RepoName "b") CombineStrategySkip+            ]+        )+        @?= ActiveRepos []+  , testCase "list without any skipped entries is unchanged" $+      let ar =+            ActiveRepos+              [ ActiveRepo (RepoName "a") CombineStrategyMerge+              , ActiveRepo (RepoName "b") CombineStrategyOverride+              ]+       in filterSkippedActiveRepos ar @?= ar+  , testCase "skipped entries are kept when :rest is present" $+      -- filterSkippedActiveRepos is a no-op when ActiveRepoRest appears+      let ar =+            ActiveRepos+              [ ActiveRepoRest CombineStrategyMerge+              , ActiveRepo (RepoName "b") CombineStrategySkip+              ]+       in filterSkippedActiveRepos ar @?= ar+  , testCase ":rest with skip strategy is kept unchanged" $+      let ar = ActiveRepos [ActiveRepoRest CombineStrategySkip]+       in filterSkippedActiveRepos ar @?= ar+  ]++-------------------------------------------------------------------------------+-- Parse/pretty roundtrip+-------------------------------------------------------------------------------++prop_activeReposRoundtrip :: ActiveRepos -> Property+prop_activeReposRoundtrip ar =+  counterexample ("prettyShow: " ++ prettyShow ar) $+    simpleParsec (prettyShow ar) === Just ar
tests/UnitTests/Distribution/Client/Init.hs view
@@ -41,11 +41,11 @@       , NonInteractive.tests v initFlags' comp pkgIx srcDb       , Golden.tests v initFlags' pkgIx srcDb       , Simple.tests v initFlags' pkgIx srcDb-      , FileCreators.tests v initFlags' comp pkgIx srcDb+      , FileCreators.tests v initFlags' pkgIx srcDb       ]   where     v :: Verbosity-    v = normal+    v = mkVerbosity defaultVerbosityHandles normal      compFlags :: ConfigFlags     compFlags = mempty{configHcPath = initHcPath emptyFlags}
tests/UnitTests/Distribution/Client/Init/FileCreators.hs view
@@ -14,7 +14,6 @@ import Distribution.Client.Init.NonInteractive.Command import Distribution.Client.Init.Types import Distribution.Client.Types-import Distribution.Simple import Distribution.Simple.Flag import Distribution.Simple.PackageIndex import Distribution.Verbosity@@ -22,11 +21,10 @@ tests   :: Verbosity   -> InitFlags-  -> Compiler   -> InstalledPackageIndex   -> SourcePackageDb   -> TestTree-tests _v _initFlags comp pkgIx srcDb =+tests _v _initFlags pkgIx srcDb =   testGroup     "Distribution.Client.Init.FileCreators"     [ testCase "Check . as source directory" $ do@@ -36,7 +34,7 @@                 , minimal = Flag False                 , overwrite = Flag False                 , packageDir = Flag "/home/test/test-package"-                , extraDoc = Flag ["CHANGELOG.md"]+                , extraDoc = Flag ["CHANGELOG.md", "README.md"]                 , exposedModules = Flag []                 , otherModules = Flag []                 , otherExts = Flag []@@ -82,7 +80,7 @@               ]          case flip runPrompt inputs $ do-          projSettings <- createProject comp silent pkgIx srcDb dummyFlags'+          projSettings <- createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags'           writeProject projSettings of           Left (BreakException ex) -> assertFailure $ show ex           Right _ -> return ()
tests/UnitTests/Distribution/Client/Init/Golden.hs view
@@ -84,22 +84,22 @@     [ goldenVsString         "Empty flags, non-simple, no comments"         (goldenPkgDesc "pkg.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runPkgDesc opts emptyFlags pkgArgs     , goldenVsString         "Empty flags, non-simple, with comments"         (goldenPkgDesc "pkg-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runPkgDesc opts emptyFlags pkgArgs     , goldenVsString         "Dummy flags, >= cabal version syntax, with comments"         (goldenPkgDesc "pkg-with-flags.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV1_0}) pkgArgs     , goldenVsString         "Dummy flags, old cabal version, with comments"         (goldenPkgDesc "pkg-old-cabal-with-flags.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV2_0}) pkgArgs     ]   where@@ -120,27 +120,27 @@     [ goldenVsString         "Empty flags, not simple, no options, no comments"         (goldenExe "exe-no-comments.golden")-        $ let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion+        $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion            in runGoldenExe opts exeArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with comments + no minimal"         (goldenExe "exe-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion            in runGoldenExe opts exeArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with minimal + no comments"         (goldenExe "exe-minimal-no-comments.golden")-        $ let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion+        $ let opts = WriteOpts False True True (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion            in runGoldenExe opts exeArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with minimal + comments"         (goldenExe "exe-simple-minimal-with-comments.golden")-        $ let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion+        $ let opts = WriteOpts False True False (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion            in runGoldenExe opts exeArgs emptyFlags     , goldenVsString         "Build tools flag, not simple, with comments + no minimal"         (goldenExe "exe-build-tools-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion            in runGoldenExe opts exeArgs (emptyFlags{buildTools = Flag ["happy"]})     ]   where@@ -161,32 +161,32 @@     [ goldenVsString         "Empty flags, not simple, no options, no comments"         (goldenLib "lib-no-comments.golden")-        $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenLib opts libArgs emptyFlags     , goldenVsString         "Empty flags, simple, no options, no comments"         (goldenLib "lib-simple-no-comments.golden")-        $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenLib opts libArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with comments + no minimal"         (goldenLib "lib-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenLib opts libArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with minimal + no comments"         (goldenLib "lib-minimal-no-comments.golden")-        $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False True True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenLib opts libArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with minimal + comments"         (goldenLib "lib-simple-minimal-with-comments.golden")-        $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False True False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenLib opts libArgs emptyFlags     , goldenVsString         "Build tools flag, not simple, with comments + no minimal"         (goldenLib "lib-build-tools-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenLib opts libArgs (emptyFlags{buildTools = Flag ["happy"]})     ]   where@@ -207,37 +207,37 @@     [ goldenVsString         "Empty flags, not simple, no options, no comments"         (goldenTest "test-no-comments.golden")-        $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenTest opts testArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with comments + no minimal"         (goldenTest "test-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenTest opts testArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with minimal + no comments"         (goldenTest "test-minimal-no-comments.golden")-        $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False True True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenTest opts testArgs emptyFlags     , goldenVsString         "Empty flags, not simple, with minimal + comments"         (goldenTest "test-simple-minimal-with-comments.golden")-        $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False True False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenTest opts testArgs emptyFlags     , goldenVsString         "Build tools flag, not simple, with comments + no minimal"         (goldenTest "test-build-tools-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion            in runGoldenTest opts testArgs (emptyFlags{buildTools = Flag ["happy"]})     , goldenVsString         "Standalone tests, empty flags, not simple, no options, no comments"         (goldenTest "standalone-test-no-comments.golden")-        $ let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion+        $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir TestSuite pkgName defaultCabalVersion            in runGoldenTest opts testArgs emptyFlags     , goldenVsString         "Standalone tests, empty flags, not simple, with comments + no minimal"         (goldenTest "standalone-test-with-comments.golden")-        $ let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion+        $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir TestSuite pkgName defaultCabalVersion            in runGoldenTest opts testArgs emptyFlags     ]   where@@ -289,25 +289,31 @@         Left e -> assertFailure $ show e         (Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do           let pkgFields = mkPkgDescription opts pkgDesc-              commonStanza = mkCommonStanza opts+              rtsOptionsStanza = mkRtsOptionsStanza opts+              ghcOptionsStanza = mkGhcOptionsStanza opts+              extensionsStanza = mkExtensionsStanza opts               libStanza = mkLibStanza opts $ libTarget{_libDependencies = mangleBaseDep libTarget _libDependencies}               exeStanza = mkExeStanza opts $ exeTarget{_exeDependencies = mangleBaseDep exeTarget _exeDependencies}               testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies} -          mkStanza $ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]+          mkStanza $ pkgFields ++ [extensionsStanza, ghcOptionsStanza, rtsOptionsStanza, libStanza, exeStanza, testStanza]         (Right (ProjectSettings opts pkgDesc (Just libTarget) Nothing (Just testTarget), _)) -> do           let pkgFields = mkPkgDescription opts pkgDesc-              commonStanza = mkCommonStanza opts+              rtsOptionsStanza = mkRtsOptionsStanza opts+              ghcOptionsStanza = mkGhcOptionsStanza opts+              extensionsStanza = mkExtensionsStanza opts               libStanza = mkLibStanza opts $ libTarget{_libDependencies = mangleBaseDep libTarget _libDependencies}               testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies} -          mkStanza $ pkgFields ++ [commonStanza, libStanza, testStanza]+          mkStanza $ pkgFields ++ [extensionsStanza, ghcOptionsStanza, rtsOptionsStanza, libStanza, testStanza]         (Right (ProjectSettings opts pkgDesc Nothing Nothing (Just testTarget), _)) -> do           let pkgFields = mkPkgDescription opts pkgDesc-              commonStanza = mkCommonStanza opts+              rtsOptionsStanza = mkRtsOptionsStanza opts+              ghcOptionsStanza = mkGhcOptionsStanza opts+              extensionsStanza = mkExtensionsStanza opts               testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies} -          mkStanza $ pkgFields ++ [commonStanza, testStanza]+          mkStanza $ pkgFields ++ [extensionsStanza, ghcOptionsStanza, rtsOptionsStanza, testStanza]         (Right (ProjectSettings _ _ l e t, _)) ->           assertFailure $             show l ++ "\n" ++ show e ++ "\n" ++ show t
tests/UnitTests/Distribution/Client/Init/Interactive.hs view
@@ -76,7 +76,7 @@                     , dependencies = Flag []                     } -            case (runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["[]", "3", "quxTest/Main.hs"]) of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') (fromList ["[]", "3", "quxTest/Main.hs"]) of               Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -96,7 +96,7 @@                 _pkgSynopsis desc @?= "We are Qux, and this is our package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["quxSrc"]                 _libLanguage lib @?= Haskell98@@ -186,7 +186,7 @@                       "y"                     ] -            case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -206,7 +206,7 @@                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell98@@ -286,7 +286,7 @@                       "y"                     ] -            case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -306,7 +306,7 @@                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell98@@ -372,7 +372,7 @@                       "y"                     ] -            case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -392,7 +392,7 @@                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _testMainIs test @?= HsFilePath "Main.hs" Standard                 _testDirs test @?= ["test"]@@ -460,7 +460,7 @@                       "y"                     ] -            case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -480,7 +480,7 @@                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell98@@ -546,7 +546,7 @@                       "y"                     ] -            case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -566,7 +566,7 @@                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell98@@ -627,11 +627,11 @@                 flags =                   emptyFlags                     { cabalVersion = Flag CabalSpecV1_10-                    , extraDoc = Flag [defaultChangelog]+                    , extraDoc = Flag [defaultChangelog, defaultReadme]                     , extraSrc = Flag ["README.md"]                     } -            case (runPrompt $ createProject silent pkgIx srcDb flags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb flags) inputs of               Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -650,7 +650,7 @@                 _pkgHomePage desc @?= "qux.com"                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"-                _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"]+                _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, defaultReadme]                 _pkgExtraDocFiles desc @?= Nothing                  _libSourceDirs lib @?= ["src"]@@ -709,7 +709,7 @@                       "y"                     ] -            case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -729,7 +729,7 @@                 _pkgSynopsis desc @?= "Qux's package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _exeMainIs exe @?= HsFilePath "Main.hs" Standard                 _exeApplicationDirs exe @?= ["exe"]@@ -1105,8 +1105,7 @@   testPrompt label f (assertFailure . show) (\(a, _) -> target @=? a)  testPromptBreak-  :: Eq a-  => Show a+  :: Show a   => String   -> (InitFlags -> PurePrompt a)   -> [String]@@ -1118,9 +1117,7 @@       return ()  testPrompt-  :: Eq a-  => Show a-  => String+  :: String   -> (InitFlags -> PurePrompt a)   -> (BreakException -> Assertion)   -> ((a, NonEmpty String) -> Assertion)
tests/UnitTests/Distribution/Client/Init/NonInteractive.hs view
@@ -44,11 +44,11 @@     "Distribution.Client.Init.NonInteractive.Command"     [ testGroup         "driver function test"-        [ driverFunctionTest pkgIx srcDb comp+        [ driverFunctionTest pkgIx srcDb         ]     , testGroup         "target creator tests"-        [ fileCreatorTests pkgIx srcDb comp+        [ fileCreatorTests pkgIx srcDb         ]     , testGroup         "non-interactive tests"@@ -63,9 +63,8 @@ driverFunctionTest   :: InstalledPackageIndex   -> SourcePackageDb-  -> Compiler   -> TestTree-driverFunctionTest pkgIx srcDb comp =+driverFunctionTest pkgIx srcDb =   testGroup     "createProject"     [ testGroup@@ -77,7 +76,7 @@                     , minimal = Flag False                     , overwrite = Flag False                     , packageDir = Flag "/home/test/test-package"-                    , extraDoc = Flag ["CHANGELOG.md"]+                    , extraDoc = Flag ["CHANGELOG.md", "README.md"]                     , exposedModules = Flag []                     , otherModules = Flag []                     , otherExts = Flag []@@ -93,7 +92,7 @@                     , "[\"quxTest/Main.hs\"]"                     ] -            case (runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of               Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -113,7 +112,7 @@                 _pkgSynopsis desc @?= "We are Qux, and this is our package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["quxSrc"]                 _libLanguage lib @?= Haskell98@@ -168,7 +167,7 @@                     [ "Foobar"                     , "foobar@qux.com"                     , -- extra sources-                      "[\"CHANGELOG.md\"]"+                      "[\"CHANGELOG.md\", \"README.md\"]"                     , -- lib other modules                       "False"                     , -- exe other modules@@ -180,7 +179,7 @@                       "False"                     ] -            case (runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of               Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -200,7 +199,7 @@                 _pkgSynopsis desc @?= "We are Qux, and this is our package"                 _pkgCategory desc @?= "Control"                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["quxSrc"]                 _libLanguage lib @?= Haskell98@@ -358,8 +357,7 @@              case ( runPrompt $                     createProject-                      comp-                      silent+                      (mkVerbosity defaultVerbosityHandles silent)                       pkgIx                       srcDb                       ( emptyFlags@@ -388,12 +386,12 @@                 _pkgSynopsis desc @?= ""                 _pkgCategory desc @?= ""                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell2010                 _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])-                _libOtherModules lib @?= map fromString ["Baz.Internal"]+                _libOtherModules lib @?= [fromString "Baz.Internal"]                 _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]                 _libDependencies lib @?! []                 _libBuildTools lib @?= [mkStringyDep "happy:happy"]@@ -510,8 +508,7 @@              case ( runPrompt $                     createProject-                      comp-                      silent+                      (mkVerbosity defaultVerbosityHandles silent)                       pkgIx                       srcDb                       ( emptyFlags@@ -540,12 +537,12 @@                 _pkgSynopsis desc @?= ""                 _pkgCategory desc @?= ""                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell2010                 _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])-                _libOtherModules lib @?= map fromString ["Baz.Internal"]+                _libOtherModules lib @?= [fromString "Baz.Internal"]                 _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]                 _libDependencies lib @?! []                 _libBuildTools lib @?= [mkStringyDep "happy:happy"]@@ -664,7 +661,7 @@                     , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"                     ] -            case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -684,12 +681,12 @@                 _pkgSynopsis desc @?= ""                 _pkgCategory desc @?= ""                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell2010                 _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])-                _libOtherModules lib @?= map fromString ["Baz.Internal"]+                _libOtherModules lib @?= [fromString "Baz.Internal"]                 _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]                 _libDependencies lib @?! []                 _libBuildTools lib @?= [mkStringyDep "happy:happy"]@@ -774,7 +771,7 @@                     , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"                     ] -            case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -794,12 +791,12 @@                 _pkgSynopsis desc @?= ""                 _pkgCategory desc @?= ""                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _libSourceDirs lib @?= ["src"]                 _libLanguage lib @?= Haskell2010                 _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])-                _libOtherModules lib @?= map fromString ["Baz.Internal"]+                _libOtherModules lib @?= [fromString "Baz.Internal"]                 _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]                 _libDependencies lib @?! []                 _libBuildTools lib @?= [mkStringyDep "happy:happy"]@@ -865,7 +862,7 @@                     , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"                     ] -            case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of+            case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of               Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do                 _optOverwrite opts @?= False                 _optMinimal opts @?= False@@ -885,7 +882,7 @@                 _pkgSynopsis desc @?= ""                 _pkgCategory desc @?= ""                 _pkgExtraSrcFiles desc @?= mempty-                _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")+                _pkgExtraDocFiles desc @?= pure (Set.fromList ["CHANGELOG.md", "README.md"])                  _exeMainIs exe @?= HsFilePath "Main.hs" Standard                 _exeApplicationDirs exe @?= ["app"]@@ -905,9 +902,8 @@ fileCreatorTests   :: InstalledPackageIndex   -> SourcePackageDb-  -> Compiler   -> TestTree-fileCreatorTests pkgIx srcDb comp =+fileCreatorTests pkgIx srcDb =   testGroup     "generators"     [ testGroup@@ -980,7 +976,7 @@                     , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"                     ] -            case (runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of+            case (runPrompt $ genLibTarget emptyFlags pkgIx defaultCabalVersion) inputs of               Left e -> assertFailure $ show e               Right{} -> return ()         ]@@ -1021,7 +1017,7 @@                     , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"                     ] -            case (runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of+            case (runPrompt $ genExeTarget emptyFlags pkgIx defaultCabalVersion) inputs of               Left e -> assertFailure $ show e               Right{} -> return ()         ]@@ -1058,7 +1054,7 @@                     ]                 flags = emptyFlags{initializeTestSuite = Flag True} -            case (runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of+            case (runPrompt $ genTestTarget flags pkgIx defaultCabalVersion) inputs of               Left e -> assertFailure $ show e               Right{} -> return ()         ]@@ -1168,38 +1164,20 @@                 ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"]             ]         , testGroup-            "Check languageHeuristics output"-            [ testSimple-                "Non GHC compiler"-                (`languageHeuristics` (comp{compilerId = CompilerId Helium $ mkVersion [1, 8, 1]}))-                Haskell2010-                []-            , testSimple-                "Higher version compiler"-                (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [8, 10, 4]}))-                Haskell2010-                []-            , testSimple-                "Lower version compiler"-                (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [6, 0, 1]}))-                Haskell98-                []-            ]-        , testGroup             "Check extraDocFileHeuristics output"             [ testSimple                 "No extra sources"                 extraDocFileHeuristics-                (pure (Set.singleton "CHANGELOG.md"))+                (pure (Set.fromList ["CHANGELOG.md", "README.md"]))                 [ "test-package"                 , "[]"                 ]             , testSimple                 "Extra doc files present"                 extraDocFileHeuristics-                (pure $ Set.singleton "README.md")+                (pure $ Set.fromList ["CHANGELOG.md", "README.md"])                 [ "test-package"-                , "[\"README.md\"]"+                , "[\"CHANGELOG.md\", \"README.md\"]"                 ]             ]         , testGroup@@ -1268,7 +1246,7 @@             [ testSimple                 "Library directory exists"                 libOtherModulesHeuristics-                (map fromString ["Baz.Internal"])+                [fromString "Baz.Internal"]                 [ "test-package"                 , "True"                 , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"@@ -1394,9 +1372,7 @@   testSimple label f target [input]  testGo-  :: Eq a-  => Show a-  => String+  :: String   -> (InitFlags -> PurePrompt a)   -> (BreakException -> Assertion)   -> ((a, NEL.NonEmpty String) -> Assertion)@@ -1427,7 +1403,7 @@         flags <- runParserTest ["--extra-doc-file", "README"]         flags           @?= emptyFlags-            { extraDoc = Flag $ ["README"]+            { extraDoc = Flag ["README"]             }     , testCase "Multiple extraDoc" $ do         flags <-@@ -1447,7 +1423,7 @@         flags <- runParserTest ["-o", "Test"]         flags           @?= emptyFlags-            { exposedModules = Flag $ map fromString ["Test"]+            { exposedModules = Flag [fromString "Test"]             }     , testCase "Multiple exposedModules" $ do         flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
tests/UnitTests/Distribution/Client/Init/Simple.hs view
@@ -63,7 +63,7 @@             flags = emptyFlags{packageType = Flag Library}             settings =               ProjectSettings-                (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)+                (WriteOpts False False False (verbosityFlags v) "/home/test/1" Library pkgName defaultCabalVersion)                 (simplePkgDesc pkgName)                 (Just $ simpleLibTarget baseDep)                 Nothing@@ -77,7 +77,7 @@             flags = emptyFlags{packageType = Flag Library}             settings =               ProjectSettings-                (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)+                (WriteOpts False False False (verbosityFlags v) "/home/test/1" Library pkgName defaultCabalVersion)                 (simplePkgDesc pkgName)                 (Just $ simpleLibTarget baseDep)                 Nothing@@ -91,7 +91,7 @@             flags = emptyFlags{packageType = Flag Executable}             settings =               ProjectSettings-                (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion)+                (WriteOpts False False False (verbosityFlags v) "/home/test/2" Executable pkgName defaultCabalVersion)                 (simplePkgDesc pkgName)                 Nothing                 (Just $ simpleExeTarget Nothing baseDep)@@ -105,7 +105,7 @@             flags = emptyFlags{packageType = Flag LibraryAndExecutable}             settings =               ProjectSettings-                (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)+                (WriteOpts False False False (verbosityFlags v) "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)                 (simplePkgDesc pkgName)                 (Just $ simpleLibTarget baseDep)                 (Just $ simpleExeTarget (Just pkgName) baseDep)@@ -119,7 +119,7 @@             flags = emptyFlags{packageType = Flag LibraryAndExecutable}             settings =               ProjectSettings-                (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)+                (WriteOpts False False False (verbosityFlags v) "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)                 (simplePkgDesc pkgName)                 (Just $ simpleLibTarget baseDep)                 (Just $ simpleExeTarget (Just pkgName) baseDep)@@ -133,7 +133,7 @@             flags = emptyFlags{packageType = Flag TestSuite}             settings =               ProjectSettings-                (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion)+                (WriteOpts False False False (verbosityFlags v) "/home/test/2" TestSuite pkgName defaultCabalVersion)                 (simplePkgDesc pkgName)                 Nothing                 Nothing@@ -168,7 +168,7 @@     ""     ""     mempty-    (Just $ Set.singleton defaultChangelog)+    (Just $ Set.fromList [defaultReadme, defaultChangelog])  simpleLibTarget :: [Dependency] -> LibTarget simpleLibTarget baseDep =
tests/UnitTests/Distribution/Client/InstallPlan.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} @@ -136,7 +137,7 @@     | let ixs =             array               (bounds g)-              ( zip (range (bounds g)) (repeat Nothing)+              ( map (,Nothing) (range (bounds g))                   ++ zip vs (map Just [0 :: Int ..])               )     , (u, v) <- edges g
tests/UnitTests/Distribution/Client/ProjectConfig.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- simplifier goes nuts otherwise@@ -26,7 +27,6 @@ import Distribution.Deprecated.ParseUtils import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Compiler import Distribution.Package import Distribution.PackageDescription import qualified Distribution.Simple.InstallDirs as InstallDirs@@ -35,7 +35,6 @@ import Distribution.Simple.Utils (toUTF8BS) import Distribution.System (OS (Windows), buildOS) import Distribution.Types.PackageVersionConstraint-import Distribution.Version  import Distribution.Parsec import Distribution.Pretty@@ -47,7 +46,7 @@ import Distribution.Client.Types import Distribution.Client.Types.SourceRepo import Distribution.Utils.NubList-import Distribution.Verbosity (silent)+import Distribution.Verbosity  import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint@@ -73,16 +72,10 @@       , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly       , testProperty "specific" prop_roundtrip_legacytypes_specific       ]-        ++-        -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older-        -- unclear why as of yet-        concat-          [ [ testProperty "shared" prop_roundtrip_legacytypes_shared-            , testProperty "local" prop_roundtrip_legacytypes_local-            , testProperty "all" prop_roundtrip_legacytypes_all-            ]-          | not usingGhc76orOlder-          ]+        ++ [ testProperty "shared" prop_roundtrip_legacytypes_shared+           , testProperty "local" prop_roundtrip_legacytypes_local+           , testProperty "all" prop_roundtrip_legacytypes_all+           ]   , testGroup       "individual parser tests"       [ testProperty "package location" prop_parsePackageLocationTokenQ@@ -102,11 +95,6 @@   , testGetProjectRootUsability   , testFindProjectRoot   ]-  where-    usingGhc76orOlder =-      case buildCompilerId of-        CompilerId GHC v -> v < mkVersion [7, 7]-        _ -> False  testGetProjectRootUsability :: TestTree testGetProjectRootUsability =@@ -175,17 +163,17 @@      test name wrap projectDir projectFile validate =       testCaseSteps name $ \step -> fromMaybe id wrap $ do-        result <- findProjectRoot silent projectDir projectFile+        result <- findProjectRoot (mkVerbosity defaultVerbosityHandles silent) projectDir projectFile         _ <- validate result          when (isRight result) $ do           for_ projectDir $ \path -> do             step "missing project dir"-            fails =<< findProjectRoot silent (missing path) projectFile+            fails =<< findProjectRoot (mkVerbosity defaultVerbosityHandles silent) (missing path) projectFile            for_ projectFile $ \path -> do             step "missing project file"-            fails =<< findProjectRoot silent projectDir (missing path)+            fails =<< findProjectRoot (mkVerbosity defaultVerbosityHandles silent) projectDir (missing path)      cd d = Just (withCurrentDirectory d) @@ -376,7 +364,7 @@ -- | Helper to parse a given string -- -- Succeeds only if there is a unique complete parse-runReadP :: Parse.ReadP a a -> String -> Maybe a+runReadP :: Parse.ReadP a -> String -> Maybe a runReadP parser s = case [x | (x, "") <- Parse.readP_to_S parser s] of   [x'] -> Just x'   _ -> Nothing@@ -418,8 +406,7 @@  instance Arbitrary ProjectConfig where   arbitrary =-    ProjectConfig-      <$> (map getPackageLocationString <$> arbitrary)+    (ProjectConfig . map getPackageLocationString <$> arbitrary)       <*> (map getPackageLocationString <$> arbitrary)       <*> shortListOf 3 arbitrary       <*> arbitrary@@ -458,9 +445,8 @@         , projectConfigProvenance = x6'         , projectConfigLocalPackages = x7'         , projectConfigSpecificPackage =-            ( MapMappend-                (fmap getNonMEmpty x8')-            )+            MapMappend+              (fmap getNonMEmpty x8')         , projectConfigAllPackages = x9'         }       | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <-@@ -606,6 +592,7 @@     projectConfigConfigFile <- arbitraryFlag arbitraryShortToken     projectConfigProjectDir <- arbitraryFlag arbitraryShortToken     projectConfigProjectFile <- arbitraryFlag arbitraryShortToken+    projectConfigProjectFileParser <- arbitraryFlag arbitrary     projectConfigIgnoreProject <- arbitrary     projectConfigHcFlavor <- arbitrary     projectConfigHcPath <- arbitraryFlag arbitraryShortToken@@ -642,7 +629,7 @@     where       arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]       arbitraryConstraints =-        fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary+        fmap (,projectConfigConstraintSource) <$> arbitrary       fixInstallDirs x = x{InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty}    shrink ProjectConfigShared{..} =@@ -652,6 +639,7 @@         <*> shrinker projectConfigConfigFile         <*> shrinker projectConfigProjectDir         <*> shrinker projectConfigProjectFile+        <*> shrinker projectConfigProjectFileParser         <*> shrinker projectConfigIgnoreProject         <*> shrinker projectConfigHcFlavor         <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath@@ -686,25 +674,27 @@         <*> shrinker projectConfigMultiRepl     where       preShrink_Constraints = map fst-      postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))+      postShrink_Constraints = map (,projectConfigConstraintSource)  projectConfigConstraintSource :: ConstraintSource projectConfigConstraintSource = ConstraintSourceProjectConfig nullProjectConfigPath +instance Arbitrary ProjectFileParser where+  arbitrary = elements [ParsecParser, LegacyParser, FallbackParser, CompareParser]+ instance Arbitrary ProjectConfigProvenance where   arbitrary = elements [Implicit, Explicit (ProjectConfigPath $ "cabal.project" :| [])]  instance Arbitrary PackageConfig where   arbitrary =-    PackageConfig-      <$> ( MapLast . Map.fromList-              <$> shortListOf-                10-                ( (,)-                    <$> arbitraryProgramName-                    <*> arbitraryShortToken-                )+    ( PackageConfig . MapLast . Map.fromList+        <$> shortListOf+          10+          ( (,)+              <$> arbitraryProgramName+              <*> arbitraryShortToken           )+    )       <*> ( MapMappend . Map.fromList               <$> shortListOf                 10@@ -726,6 +716,7 @@       <*> arbitrary       <*> arbitrary       <*> arbitrary+      <*> arbitrary       <*> shortListOf 5 arbitraryShortToken       <*> arbitrary       <*> arbitrary@@ -779,7 +770,7 @@       arbitraryProgramName =         elements           [ programName prog-          | (prog, _) <- knownPrograms (defaultProgramDb)+          | (prog, _) <- knownPrograms defaultProgramDb           ]    shrink@@ -791,6 +782,7 @@       , packageConfigVanillaLib = x04       , packageConfigSharedLib = x05       , packageConfigStaticLib = x42+      , packageConfigBytecodeLib = x43       , packageConfigDynExe = x06       , packageConfigFullyStaticExe = x50       , packageConfigProf = x07@@ -830,7 +822,7 @@       , packageConfigHaddockInternal = x36       , packageConfigHaddockCss = x37       , packageConfigHaddockLinkedSource = x38-      , packageConfigHaddockQuickJump = x43+      , packageConfigHaddockQuickJump = x59       , packageConfigHaddockHscolourCss = x39       , packageConfigHaddockContents = x40       , packageConfigHaddockForHackage = x41@@ -856,6 +848,7 @@         , packageConfigVanillaLib = x04'         , packageConfigSharedLib = x05'         , packageConfigStaticLib = x42'+        , packageConfigBytecodeLib = x43'         , packageConfigDynExe = x06'         , packageConfigFullyStaticExe = x50'         , packageConfigProf = x07'@@ -895,7 +888,7 @@         , packageConfigHaddockInternal = x36'         , packageConfigHaddockCss = fmap getNonEmpty x37'         , packageConfigHaddockLinkedSource = x38'-        , packageConfigHaddockQuickJump = x43'+        , packageConfigHaddockQuickJump = x59'         , packageConfigHaddockHscolourCss = fmap getNonEmpty x39'         , packageConfigHaddockContents = x40'         , packageConfigHaddockForHackage = x41'@@ -914,14 +907,14 @@         , packageConfigBenchmarkOptions = x52'         }       | ( ( (x00', x01', x02', x03', x04')-            , (x05', x42', x06', x50', x07', x08', x08_1', x09')+            , (x05', x42', x43', x06', x50', x07', x08', x08_1', x09')             , (x10', x11', x12', x13', x14')             , (x15', x16', x53', x17', x18', x19')             )           , ( (x20', x20_1', x21', x22', x23', x24')               , (x25', x26', x27', x27_1', x28', x29')               , (x30', x31', x32', (x33', x33_1'), x34')-              , (x35', x36', x37', x38', x43', x39')+              , (x35', x36', x37', x38', x59', x39')               , (x40', x41')               , (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55')               , x56'@@ -932,7 +925,7 @@           shrink             (               ( (preShrink_Paths x00, preShrink_Args x01, x02, x03, x04)-              , (x05, x42, x06, x50, x07, x08, x08_1, x09)+              , (x05, x42, x43, x06, x50, x07, x08, x08_1, x09)               , (x10, x11, map NonEmpty x12, x13, x14)               ,                 ( x15@@ -947,7 +940,7 @@               ( (x20, x20_1, x21, x22, x23, x24)               , (x25, x26, x27, x27_1, x28, x29)               , (x30, x31, x32, (x33, x33_1), x34)-              , (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39)+              , (x35, x36, fmap NonEmpty x37, x38, x59, fmap NonEmpty x39)               , (x40, x41)               , (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55)               , x56
tests/UnitTests/Distribution/Client/Store.hs view
@@ -12,7 +12,7 @@ import Distribution.Package (UnitId, mkUnitId) import Distribution.Simple.Compiler (AbiTag (..), Compiler (..), CompilerFlavor (..), CompilerId (..)) import Distribution.Simple.Utils (withTempDirectory)-import Distribution.Verbosity (Verbosity, silent)+import Distribution.Verbosity import Distribution.Version (mkVersion)  import Distribution.Client.RebuildMonad@@ -31,7 +31,7 @@  testListEmpty :: Assertion testListEmpty =-  withTempDirectory verbosity "." "store-" $ \tmp -> do+  withTempDirectory "." "store-" $ \tmp -> do     let storeDirLayout = defaultStoreDirLayout (tmp </> "store")      assertStoreEntryExists storeDirLayout compiler unitid False@@ -46,13 +46,14 @@         , compilerLanguages = []         , compilerExtensions = []         , compilerProperties = mempty+        , compilerWiredInUnitIds = Nothing         }      unitid = mkUnitId "foo-1.0-xyz"  testInstallSerial :: Assertion testInstallSerial =-  withTempDirectory verbosity "." "store-" $ \tmp -> do+  withTempDirectory "." "store-" $ \tmp -> do     let storeDirLayout = defaultStoreDirLayout (tmp </> "store")         copyFiles file content dir = do           -- we copy into a prefix inside the tmp dir and return the prefix@@ -102,6 +103,7 @@         , compilerLanguages = []         , compilerExtensions = []         , compilerProperties = mempty+        , compilerWiredInUnitIds = Nothing         }      unitid1 = mkUnitId "foo-1.0-xyz"@@ -115,7 +117,7 @@  testInstallParallel :: Assertion testInstallParallel =-  withTempDirectory verbosity "." "store-" $ \tmp -> do+  withTempDirectory "." "store-" $ \tmp -> do     let storeDirLayout = defaultStoreDirLayout (tmp </> "store")      sync1 <- newEmptyMVar@@ -226,4 +228,4 @@   assertEqual ("file content for:\n" ++ path) expected actual  verbosity :: Verbosity-verbosity = silent+verbosity = mkVerbosity defaultVerbosityHandles silent
tests/UnitTests/Distribution/Client/Tar.hs view
@@ -47,8 +47,7 @@           Next e2 Done   assertEqual "Unexpected result for filter" "z" $     entriesToString $-      filterEntries p $-        Done+      filterEntries p Done   assertEqual "Unexpected result for filter" "xf" $     entriesToString $       filterEntries p $@@ -72,7 +71,7 @@   assertEqual "Unexpected result for filterM" "xz" $ entriesToString r   assertEqual "Unexpected result for filterM w" "tt" w -  (r1, w1) <- runWriterT $ filterEntriesM p $ Done+  (r1, w1) <- runWriterT $ filterEntriesM p Done   assertEqual "Unexpected result for filterM" "z" $ entriesToString r1   assertEqual "Unexpected result for filterM w" "" w1
tests/UnitTests/Distribution/Client/TreeDiffInstances.hs view
@@ -63,6 +63,7 @@ instance ToExpr ProjectConfigBuildOnly instance ToExpr ProjectConfigProvenance instance ToExpr ProjectConfigShared+instance ToExpr ProjectFileParser instance ToExpr RelaxDepMod instance ToExpr RelaxDeps instance ToExpr RelaxDepScope
tests/UnitTests/Distribution/Client/UserConfig.hs view
@@ -6,24 +6,24 @@  import Control.Exception (bracket) import Control.Monad (replicateM_)-import Data.List (nub, sort)+import Data.List (sort) import System.Directory   ( doesFileExist   , getCurrentDirectory   , getTemporaryDirectory   ) import System.FilePath ((</>))+import System.IO (hClose, openTempFile)  import Test.Tasty import Test.Tasty.HUnit  import Distribution.Client.Config import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))-import Distribution.Client.Utils (removeExistingFile) import Distribution.Simple.Setup (ConfigFlags (..), fromFlag, pattern Flag)-import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Simple.Utils (ordNub, removeFileForcibly, withTempDirectory) import Distribution.Utils.NubList (fromNubList)-import Distribution.Verbosity (silent)+import Distribution.Verbosity  tests :: [TestTree] tests =@@ -37,17 +37,17 @@ nullDiffOnCreateTest :: Assertion nullDiffOnCreateTest = bracketTest $ \configFile -> do   -- Create a new default config file in our test directory.-  _ <- createDefaultConfigFile silent [] configFile+  _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile   -- Now we read it in and compare it against the default.-  diff <- userConfigDiff silent (globalFlags configFile) []+  diff <- userConfigDiff (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) []   assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff  canDetectDifference :: Assertion canDetectDifference = bracketTest $ \configFile -> do   -- Create a new default config file in our test directory.-  _ <- createDefaultConfigFile silent [] configFile+  _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile   appendFile configFile "verbose: 0\n"-  diff <- userConfigDiff silent (globalFlags configFile) []+  diff <- userConfigDiff (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) []   assertBool (unlines $ "Should detect a difference:" : diff) $     diff == ["+ verbose: 0"] @@ -56,34 +56,34 @@   -- Write a trivial cabal file.   writeFile configFile "tests: True\n"   -- Update the config file.-  userConfigUpdate silent (globalFlags configFile) []+  userConfigUpdate (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) []   -- Load it again.-  updated <- loadConfig silent (Flag configFile)-  assertBool ("Field 'tests' should be True") $+  updated <- loadConfig (mkVerbosity defaultVerbosityHandles silent) (Flag configFile)+  assertBool "Field 'tests' should be True" $     fromFlag (configTests $ savedConfigureFlags updated)  doubleUpdateConfig :: Assertion doubleUpdateConfig = bracketTest $ \configFile -> do   -- Create a new default config file in our test directory.-  _ <- createDefaultConfigFile silent [] configFile+  _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile   -- Update it twice.-  replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) []+  replicateM_ 2 $ userConfigUpdate (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) []   -- Load it again.-  updated <- loadConfig silent (Flag configFile)+  updated <- loadConfig (mkVerbosity defaultVerbosityHandles silent) (Flag configFile) -  assertBool ("Field 'remote-repo' doesn't contain duplicates") $+  assertBool "Field 'remote-repo' doesn't contain duplicates" $     listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)-  assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $+  assertBool "Field 'extra-prog-path' doesn't contain duplicates" $     listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated)-  assertBool ("Field 'build-summary' doesn't contain duplicates") $+  assertBool "Field 'build-summary' doesn't contain duplicates" $     listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)  newDefaultConfig :: Assertion newDefaultConfig = do   sysTmpDir <- getTemporaryDirectory-  withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do+  withTempDirectory sysTmpDir "cabal-test" $ \tmpDir -> do     let configFile = tmpDir </> "tmp.config"-    _ <- createDefaultConfigFile silent [] configFile+    _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile     exists <- doesFileExist configFile     assertBool ("Config file should be written to " ++ configFile) exists @@ -93,15 +93,19 @@ listUnique :: Ord a => [a] -> Bool listUnique xs =   let sorted = sort xs-   in nub sorted == xs+   in ordNub sorted == xs  bracketTest :: (FilePath -> IO ()) -> Assertion bracketTest =   bracket testSetup testTearDown   where     testSetup :: IO FilePath-    testSetup = fmap (</> "test-user-config") getCurrentDirectory+    testSetup = do+      cwd <- getCurrentDirectory+      (configFile, h) <- openTempFile cwd "test-user-config"+      hClose h+      pure configFile      testTearDown :: FilePath -> IO ()     testTearDown configFile =-      mapM_ removeExistingFile [configFile, configFile ++ ".backup"]+      mapM_ removeFileForcibly [configFile, configFile ++ ".backup"]
tests/UnitTests/Distribution/Client/VCS.hs view
@@ -250,7 +250,7 @@      return result   where-    verbosity = silent+    verbosity = mkVerbosity defaultVerbosityHandles silent  -- ------------------------------------------------------------ @@ -282,7 +282,7 @@         Right checkoutCloneTo -> do           checkoutCloneTo tagname destRepoPath           checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState-          removeDirectoryRecursiveHack silent destRepoPath+          removeDirectoryRecursiveHack (mkVerbosity defaultVerbosityHandles silent) destRepoPath       where         destRepoPath = tmpdir </> "dest" @@ -316,7 +316,7 @@             , srpSubdir = []             , srpCommand = []             }-    verbosity = silent+    verbosity = mkVerbosity defaultVerbosityHandles silent  -- ------------------------------------------------------------ @@ -355,7 +355,7 @@             syncTargetSetIterations             seed     where-      verbosity = silent+      verbosity = mkVerbosity defaultVerbosityHandles silent        getRepoDirs :: RepoDirSet -> [FilePath]       getRepoDirs (RepoDirSet n) =@@ -453,7 +453,7 @@   arbitrary =     sized $ \n ->       oneof $-        [RepoDirSet <$> pure 1]+        [pure (RepoDirSet 1)]           ++ [RepoDirSet <$> choose (2, 5) | n >= 3]   shrink (RepoDirSet n) =     [RepoDirSet i | i <- shrink n, i > 0]@@ -738,14 +738,14 @@   -> FilePath   -> IO [(FilePath, Bool)] getDirectoryContentsRecursive ignore dir0 dir = do-  entries <- getDirectoryContents (dir0 </> dir)+  entries <- listDirectory (dir0 </> dir)   entries' <-     sequence       [ do         isdir <- doesDirectoryExist (dir0 </> dir </> entry)         return (dir </> entry, isdir)       | entry <- entries-      , not (isPrefixOf "." entry)+      , not ("." `isPrefixOf` entry)       , (dir </> entry) `Set.notMember` ignore       ]   let subdirs = [d | (d, True) <- entries']@@ -824,8 +824,7 @@  execFileUpdate :: CreateRepoAction FileUpdate execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do-  isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot </> filename)-  liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot </> filename)+  liftIO $ removePathForcibly (vcsRepoRoot </> filename)   liftIO $ writeFile (vcsRepoRoot </> filename) content   state <- State.get -- existing state, not updated   liftIO $ vcsAddFile state filename@@ -927,8 +926,7 @@           when destExists $ gitQuiet ["rm", "--force", dest]           -- If there is an old submodule git dir with the same name, remove it.           -- It most likely has a different URL and `git submodule add` will fai.-          submoduleGitDirExists <- doesDirectoryExist $ submoduleGitDir dest-          when submoduleGitDirExists $ removeDirectoryRecursive (submoduleGitDir dest)+          removePathForcibly (submoduleGitDir dest)           gitQuiet ["submodule", "add", source, dest]           gitQuiet ["submodule", "update", "--init", "--recursive", "--force"]       , vcsSwitchBranch = \RepoState{allBranches} branchname -> do@@ -989,7 +987,7 @@       gitQuiet [] = git []       gitQuiet (cmd : args) = git (cmd : verboseArg ++ args) -      verboseArg = ["--quiet" | verbosity < Verbosity.normal]+      verboseArg = ["--quiet" | Verbosity.verbosityLevel verbosity < Verbosity.Normal]        submoduleGitDir path = repoRoot </> ".git" </> "modules" </> path @@ -1000,7 +998,7 @@         dotGitModulesExists <- doesDirectoryExist dotGitModulesPath         when dotGitModulesExists $ do           git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg-          removeDirectoryRecursive dotGitModulesPath+          removePathForcibly dotGitModulesPath        updateSubmodulesAndCleanup = do         gitModulesExists <- doesFileExist gitModulesPath@@ -1068,7 +1066,7 @@       , vcsRepoRoot = repoRoot       , vcsIgnoreFiles = Set.empty       , vcsInit =-          pijul $ ["init"]+          pijul ["init"]       , vcsAddFile = \_ filename ->           pijul ["add", filename]       , vcsSubmoduleDriver = \_ ->@@ -1076,7 +1074,7 @@       , vcsAddSubmodule = \_ _ _ ->           fail "vcsAddSubmodule: pijul does not support submodules"       , vcsCommitChanges = \_state -> do-          pijul $+          pijul             [ "record"             , "-a"             , "-m 'a patch'"@@ -1092,9 +1090,9 @@       , vcsSwitchBranch = \_ branchname -> do           --        unless (branchname `Map.member` allBranches) $           --          pijul ["from-branch", branchname]-          pijul $ ["checkout", branchname]+          pijul ["checkout", branchname]       , vcsCheckoutTag = Left $ \tagname ->-          pijul $ ["checkout", tagname]+          pijul ["checkout", tagname]       }     where       gitInvocation args =@@ -1149,4 +1147,4 @@           }       hg = runProgramInvocation verbosity . hgInvocation       hg' = getProgramInvocationOutput verbosity . hgInvocation-      verboseArg = ["--quiet" | verbosity < Verbosity.normal]+      verboseArg = ["--quiet" | Verbosity.verbosityLevel verbosity < Verbosity.Normal]
tests/UnitTests/Distribution/Solver/Modular/Builder.hs view
@@ -4,6 +4,7 @@  import Distribution.Solver.Modular.Builder +import Data.Bifunctor (second) import Test.Tasty import Test.Tasty.QuickCheck @@ -15,7 +16,7 @@ -- | Simpler splits implementation splits' :: [a] -> [(a, [a])] splits' [] = []-splits' (x : xs) = (x, xs) : map (\(y, ys) -> (y, x : ys)) (splits' xs)+splits' (x : xs) = (x, xs) : map (second (x :)) (splits' xs)  splitsTest :: [Int] -> Property splitsTest xs = splits' xs === splits xs
tests/UnitTests/Distribution/Solver/Modular/DSL.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}  -- | DSL for testing the modular solver module UnitTests.Distribution.Solver.Modular.DSL@@ -77,11 +78,15 @@ import qualified Distribution.Version as C import Language.Haskell.Extension (Extension (..), Language (..)) +import qualified Distribution.Compat.Lens as L+import qualified Distribution.Types.BuildInfo.Lens as L+ -- cabal-install import Distribution.Client.Dependency import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan import Distribution.Client.Types +import Data.Foldable (fold) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource@@ -96,6 +101,7 @@ import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Variable+import Distribution.Types.UnitId (UnitId)  {-------------------------------------------------------------------------------   Example package database DSL@@ -390,9 +396,9 @@ -- these packages. type ExampleDb = [Either ExampleInstalled ExampleAvailable] -type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a+type DependencyTree a = C.CondTree C.ConfVar a -type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a+type DependencyComponent a = C.CondBranch C.ConfVar a  exDbPkgs :: ExampleDb -> [ExamplePkgName] exDbPkgs = map (either exInstName exAvName)@@ -412,7 +418,7 @@             usedFlags :: Map ExampleFlagName C.PackageFlag             usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]               where-                names = extractFlags $ CD.flatDeps (exAvDeps ex)+                names = extractFlags $ fold (exAvDeps ex)          in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:             Map.elems $ declaredFlags `Map.union` usedFlags @@ -589,37 +595,38 @@     extractFlags deps = concatMap go (depsExampleDependencies deps)       where         go :: ExampleDependency -> [ExampleFlagName]-        go (ExAny _) = []-        go (ExFix _ _) = []-        go (ExRange _ _ _) = []-        go (ExSubLibAny _ _) = []-        go (ExSubLibFix _ _ _) = []-        go (ExBuildToolAny _ _) = []-        go (ExBuildToolFix _ _ _) = []-        go (ExLegacyBuildToolAny _) = []-        go (ExLegacyBuildToolFix _ _) = []+        go ExAny{} = []+        go ExFix{} = []+        go ExRange{} = []+        go ExSubLibAny{} = []+        go ExSubLibFix{} = []+        go ExBuildToolAny{} = []+        go ExBuildToolFix{} = []+        go ExLegacyBuildToolAny{} = []+        go ExLegacyBuildToolFix{} = []         go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b-        go (ExExt _) = []-        go (ExLang _) = []-        go (ExPkg _) = []+        go ExExt{} = []+        go ExLang{} = []+        go ExPkg{} = []      -- Convert 'Dependencies' into a tree of a specific component type, using     -- the given top level component and function for creating a component at     -- any level.     mkTopLevelCondTree       :: forall a-       . Semigroup a+       . (Semigroup a, L.HasBuildInfo a)       => a       -> (C.LibraryVisibility -> C.BuildInfo -> a)       -> Dependencies       -> DependencyTree a     mkTopLevelCondTree defaultTopLevel mkComponent deps =-      let condNode = mkCondTree mkComponent deps+      let condNode :: DependencyTree a+          condNode = mkCondTree mkComponent deps        in condNode{C.condTreeData = defaultTopLevel <> C.condTreeData condNode}      -- Convert 'Dependencies' into a tree of a specific component type, using     -- the given function to generate each component.-    mkCondTree :: (C.LibraryVisibility -> C.BuildInfo -> a) -> Dependencies -> DependencyTree a+    mkCondTree :: forall a. L.HasBuildInfo a => (C.LibraryVisibility -> C.BuildInfo -> a) -> Dependencies -> DependencyTree a     mkCondTree mkComponent deps =       let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps)           (directDeps, flaggedDeps) = splitDeps libraryDeps@@ -645,11 +652,7 @@               , C.buildable = depsIsBuildable deps               }        in C.CondNode-            { C.condTreeData = component-            , -- TODO: Arguably, build-tools dependencies should also-              -- effect constraints on conditional tree. But no way to-              -- distinguish between them-              C.condTreeConstraints = map mkDirect directDeps+            { C.condTreeData = L.set L.targetBuildDepends (map mkDirect directDeps) component             , C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps             } @@ -657,7 +660,9 @@     mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name)      mkFlagged-      :: (C.LibraryVisibility -> C.BuildInfo -> a)+      :: forall a+       . L.HasBuildInfo a+      => (C.LibraryVisibility -> C.BuildInfo -> a)       -> (ExampleFlagName, Dependencies, Dependencies)       -> DependencyComponent a     mkFlagged mkComponent (f, a, b) =@@ -717,7 +722,7 @@       _ -> False  mkSimpleVersion :: ExamplePkgVersion -> C.Version-mkSimpleVersion n = C.mkVersion [n, 0, 0]+mkSimpleVersion n = C.mkVersion [n]  mkSimplePkgconfigVersion :: ExamplePkgVersion -> C.PkgconfigVersion mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion@@ -753,7 +758,7 @@ exAvPkgId ex =   C.PackageIdentifier     { pkgName = C.mkPackageName (exAvName ex)-    , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]+    , pkgVersion = C.mkVersion [exAvVersion ex]     }  exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo@@ -768,7 +773,7 @@ exInstPkgId ex =   C.PackageIdentifier     { pkgName = C.mkPackageName (exInstName ex)-    , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]+    , pkgVersion = C.mkVersion [exInstVersion ex]     }  exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage@@ -783,6 +788,8 @@   -> Maybe [Extension]   -- List of languages supported by the compiler, or Nothing if unknown.   -> Maybe [Language]+  -> Maybe [(C.PackageName, UnitId)]+  -- ^ List of units that are wired in to the compiler   -> Maybe PC.PkgConfigDb   -> [ExamplePkgName]   -> Maybe Int@@ -806,6 +813,7 @@   db   exts   langs+  wiredInUnitIds   pkgConfigDb   targets   mbj@@ -831,6 +839,7 @@         defaultCompiler           { C.compilerInfoExtensions = exts           , C.compilerInfoLanguages = langs+          , C.compilerInfoWiredInUnitIds = wiredInUnitIds           }       (inst, avai) = partitionEithers db       instIdx = exInstIdx inst@@ -866,7 +875,7 @@                                 setEnableBackjumping enableBj $                                   setSolveExecutables solveExes $                                     setGoalOrder goalOrder $-                                      setSolverVerbosity verbosity $+                                      setSolverVerbosity (C.verbosityLevel verbosity) $                                         standardInstallPolicy instIdx avaiIdx targets'       toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown @@ -883,7 +892,7 @@ extractInstallPlan   :: CI.SolverInstallPlan.SolverInstallPlan   -> [(ExamplePkgName, ExamplePkgVersion)]-extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList+extractInstallPlan = mapMaybe confPkg . CI.SolverInstallPlan.toList   where     confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int)     confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg@@ -892,7 +901,7 @@     srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int)     srcPkg cpkg =       let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg)-       in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver)+       in (C.unPackageName pn,) <$> safeHead (C.versionNumbers ver)  {-------------------------------------------------------------------------------   Auxiliary
tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs view
@@ -18,6 +18,7 @@   , preferences   , setVerbose   , enableAllTests+  , wiredInUnitIds   , solverSuccess   , solverFailure   , anySolverFailure@@ -33,6 +34,7 @@ import Prelude ()  import Data.List (elemIndex)+import GHC.Stack (withFrozenCallStack)  -- test-framework import Test.Tasty as TF@@ -50,6 +52,7 @@ import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.Variable+import Distribution.Types.UnitId (UnitId, mkUnitId) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Options @@ -106,6 +109,16 @@ enableAllTests :: SolverTest -> SolverTest enableAllTests test = test{testEnableAllTests = EnableAllTests True} +wiredInUnitIds :: SolverTest -> SolverTest+wiredInUnitIds test =+  test+    { testWiredInUnitIds =+        Just+          [ (C.mkPackageName "ghc-internal", mkUnitId "ghc-internal-1")+          , (C.mkPackageName "ghc", mkUnitId "ghc-1")+          ]+    }+ {-------------------------------------------------------------------------------   Solver tests -------------------------------------------------------------------------------}@@ -126,10 +139,11 @@   , testGoalOrder :: Maybe [ExampleVar]   , testConstraints :: [ExConstraint]   , testSoftConstraints :: [ExPreference]-  , testVerbosity :: Verbosity+  , testVerbosity :: VerbosityFlags   , testDb :: ExampleDb   , testSupportedExts :: Maybe [Extension]   , testSupportedLangs :: Maybe [Language]+  , testWiredInUnitIds :: Maybe [(C.PackageName, UnitId)]   , testPkgConfigDb :: Maybe PkgConfigDb   , testEnableAllTests :: EnableAllTests   }@@ -233,18 +247,20 @@     , testDb = db     , testSupportedExts = exts     , testSupportedLangs = langs+    , testWiredInUnitIds = Nothing     , testPkgConfigDb = pkgConfigDbFromList <$> mPkgConfigDb     , testEnableAllTests = EnableAllTests False     }  runTest :: SolverTest -> TF.TestTree-runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->+runTest SolverTest{..} = withFrozenCallStack $ askOption $ \(OptionShowSolverLog showSolverLog) ->   testCase testLabel $ do     let progress =           exResolve             testDb             testSupportedExts             testSupportedLangs+            testWiredInUnitIds             testPkgConfigDb             testTargets             testMaxBackjumps@@ -261,7 +277,7 @@             (sortGoals <$> testGoalOrder)             testConstraints             testSoftConstraints-            testVerbosity+            (mkVerbosity defaultVerbosityHandles testVerbosity)             testEnableAllTests         printMsg msg = when showSolverLog $ putStrLn msg         msgs = foldProgress (:) (const []) (const []) progress
tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -43,6 +44,7 @@ import Distribution.Verbosity import Distribution.Version +import Distribution.Simple.Utils (ordNub) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils   ( ArbitraryOrd (..)@@ -242,6 +244,7 @@             (unTestDb (testDb test))             Nothing             Nothing+            Nothing             (Just $ pkgConfigDbFromList [])             (map unPN (testTargets test))             -- The backjump limit prevents individual tests from using@@ -260,7 +263,7 @@             (unVarOrdering <$> goalOrder)             (testConstraints test)             (testPreferences test)-            normal+            (mkVerbosity defaultVerbosityHandles normal)             (EnableAllTests False)        failure :: String -> Failure@@ -342,8 +345,8 @@ instance Arbitrary SolverTest where   arbitrary = do     db <- arbitrary-    let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db)-        pkgs = nub $ map fst pkgVersions+    let pkgVersions = ordNub $ map (getName &&& getVersion) (unTestDb db)+        pkgs = ordNub $ map fst pkgVersions     Positive n <- arbitrary     targets <- randomSubset n pkgs     constraints <- case pkgVersions of@@ -557,7 +560,7 @@ -- internal libraries. arbitraryUQN :: Gen UnqualComponentName arbitraryUQN =-  mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"+  mkUnqualComponentName . (\c -> "component-" ++ [c]) <$> elements "ABC"  instance Arbitrary ExampleInstalled where   arbitrary = error "arbitrary not implemented: ExampleInstalled"
tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs view
@@ -40,7 +40,7 @@     replay <- case lookupOption options of       QuickCheckReplayLegacy override -> return override       _ -> getStdRandom random-    notice normal $ "Using --quickcheck-replay=" ++ show replay+    notice (mkVerbosity defaultVerbosityHandles normal) $ "Using --quickcheck-replay=" ++ show replay     run (setOption (QuickCheckReplayLegacy replay) options) test progress  -- | Typeclass for doing arbitrary (but law-abiding) comparisons.  See also
tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs view
@@ -35,15 +35,15 @@       \p (Blind f) ->         toProgress (retry (fromProgress p) (fromProgress . f))           === (foldProgress Step f Done (p :: Log Int) :: Log Int)-  , testProperty "failWith" $ \step failure ->-      toProgress (failWith step failure)-        === (Step step (Fail failure) :: Log Int)-  , testProperty "succeedWith" $ \step success ->-      toProgress (succeedWith step success)-        === (Step step (Done success) :: Log Int)-  , testProperty "continueWith" $ \step p ->-      toProgress (continueWith step (fromProgress p))-        === (Step step p :: Log Int)+  , testProperty "failWith" $ \step' failure ->+      toProgress (failWith step' failure)+        === (Step step' (Fail failure) :: Log Int)+  , testProperty "succeedWith" $ \step' success ->+      toProgress (succeedWith step' success)+        === (Step step' (Done success) :: Log Int)+  , testProperty "continueWith" $ \step' p ->+      toProgress (continueWith step' (fromProgress p))+        === (Step step' p :: Log Int)   , testCase "tryWith with failure" $       let failure = Fail "Error"           s = Step Success
tests/UnitTests/Distribution/Solver/Modular/Solver.hs view
@@ -182,8 +182,8 @@       , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])       , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)])       , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])-      , runTest $ setupStanzaTest1-      , runTest $ setupStanzaTest2+      , runTest setupStanzaTest1+      , runTest setupStanzaTest2       ]   , testGroup       "Base shim"@@ -198,17 +198,43 @@       , runTest $ mkTest db11s2 "baseShim8" ["A"] (solverSuccess [("A", 1)])       ]   , testGroup-      "Base and non-reinstallable"+      "Non-reinstallable base, template-haskell and ghc (GHC without wiredInUnitIds)"       [ runTest $           mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $-            solverFailure (isInfixOf "rejecting: base-1.0.0 (constraint from non-reinstallable package requires installed instance)")+            solverFailure (isInfixOf "rejecting: base-5 (constraint from non-reinstallable package requires installed instance)")       , runTest $+          mkTest dbTH "Refuse to install template-haskell without --allow-boot-library-installs" ["template-haskell"] $+            solverFailure (isInfixOf "rejecting: template-haskell-1 (constraint from non-reinstallable package requires installed instance)")+      , runTest $+          mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $+            solverFailure (isInfixOf "rejecting: ghc-2 (constraint from non-reinstallable package requires installed instance)")+      , runTest $           allowBootLibInstalls $             mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $-              solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]+              solverSuccess [("base", 5), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]+      ]+  , testGroup+      "Reinstallable base, template-haskell, but not ghc{,-internal} (GHC with wiredInUnitIds)"+      [ runTest $+          wiredInUnitIds $+            mkTest dbBase "Allows reinstalling base even without --allow-boot-library-installs" ["base"] $+              solverSuccess [("base", 5), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]       , runTest $-          mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $-            solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-reinstallable package requires installed instance)")+          wiredInUnitIds $+            mkTest dbTH "Allows reinstalling template-haskell even without --allow-boot-library-installs" ["template-haskell"] $+              solverSuccess [("base", 5), ("ghc-prim", 1), ("pretty", 1), ("template-haskell", 1)]+      , runTest $+          wiredInUnitIds $+            mkTest dbGhcInternal "Fails to reinstall ghc-internal as its wired-in" ["ghc-internal"] $+              solverFailure (isInfixOf "ghc-internal-1 (constraint from non-reinstallable package requires installed instance with unit id ghc-internal-1)")+      , runTest $+          wiredInUnitIds $+            mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $+              solverFailure (isInfixOf "rejecting: ghc-2 (constraint from non-reinstallable package requires installed instance with unit id ghc-1)")+      , runTest $+          wiredInUnitIds $+            mkTest dbBaseOld "Refuse to install very old base" ["base"] $+              solverFailure (isInfixOf "rejecting: base-1 (constraint from non-reinstallable package requires >=4.22)")       ]   , testGroup       "reject-unconstrained"@@ -230,7 +256,7 @@               solverFailure $                 isInfixOf $                   "Could not resolve dependencies:\n"-                    ++ "[__0] trying: A-3.0.0 (user goal)\n"+                    ++ "[__0] trying: A-3 (user goal)\n"                     ++ "[__1] next goal: C (dependency of A)\n"                     ++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, "                     ++ "but reject-unconstrained-dependencies was set)\n"@@ -348,8 +374,8 @@       "Pkg-config dependencies"       [ runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure       , runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure-      , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])-      , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])+      , runTest $ mkTestPCDepends (Just [("pkgA", "1"), ("pkgB", "1")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+      , runTest $ mkTestPCDepends (Just [("pkgA", "1"), ("pkgB", "2")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])       , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure       , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D", 1)])       ]@@ -392,7 +418,7 @@               ]          in runTest $               mkTest db "reject build-depends dependency with no library" ["A"] $-                solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)")+                solverFailure (isInfixOf "rejecting: B-1 (does not contain library, which is required by A)")       , let exe = exExe "exe" []             db =               [ Right $ exAv "A" 1 [ExAny "B"]@@ -412,8 +438,7 @@          in runTest $               mkTest db "reject package that is missing required sub-library" ["A"] $                 solverFailure $-                  isInfixOf $-                    "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)"+                  isInfixOf "rejecting: B-1 (does not contain library 'sub-lib', which is required by A)"       , let db =               [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]               , Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" []@@ -421,8 +446,7 @@          in runTest $               mkTest db "reject package with private but required sub-library" ["A"] $                 solverFailure $-                  isInfixOf $-                    "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"+                  isInfixOf "rejecting: B-1 (library 'sub-lib' is private, but it is required by A)"       , let db =               [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]               , Right $@@ -433,8 +457,7 @@               constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $                 mkTest db "reject package with sub-library made private by flag constraint" ["A"] $                   solverFailure $-                    isInfixOf $-                      "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"+                    isInfixOf "rejecting: B-1 (library 'sub-lib' is private, but it is required by A)"       , let db =               [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]               , Right $@@ -459,8 +482,7 @@               goalOrder goals $                 mkTest db "reject package that requires a private sub-library" ["A", "C"] $                   solverFailure $-                    isInfixOf $-                      "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)"+                    isInfixOf "rejecting: C-1 (requires library 'sub-lib' from B, but the component is private)"       , let db =               [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"]               , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies@@ -512,9 +534,9 @@               isInfixOf $                 -- The solver reports the version conflict when a version conflict                 -- and an executable conflict apply to the same package version.-                "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n"-                  ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n"-                  ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)"+                "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3)\n"+                  ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3 (does not contain executable 'exe1', which is required by H)\n"+                  ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3)"       , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success"       , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure"       , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency"@@ -569,7 +591,7 @@                     mkTest db "reject library dependency with unbuildable library" ["A"] $                       solverFailure $                         isInfixOf $-                          "rejecting: B-1.0.0 (library is not buildable in the "+                          "rejecting: B-1 (library is not buildable in the "                             ++ "current environment, but it is required by A)"           , let db =                   [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]@@ -592,7 +614,7 @@                     mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $                       solverFailure $                         isInfixOf $-                          "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not "+                          "rejecting: A:B:exe.B-1 (executable 'bt' is not "                             ++ "buildable in the current environment, but it is required by A)"           , runTest $               chooseUnbuildableExeAfterBuildToolsPackage@@ -615,17 +637,17 @@                 , Right $ exAv "B" 1 [ExAny "unknown2"]                 ]               msg =-                [ "[__0] trying: A-4.0.0 (user goal)"-                , "[__1] trying: B-2.0.0 (dependency of A)"+                [ "[__0] trying: A-4 (user goal)"+                , "[__1] trying: B-2 (dependency of A)"                 , "[__2] unknown package: unknown1 (dependency of B)"                 , "[__2] fail (backjumping, conflict set: B, unknown1)"-                , "[__1] trying: B-1.0.0"+                , "[__1] trying: B-1"                 , "[__2] unknown package: unknown2 (dependency of B)"                 , "[__2] fail (backjumping, conflict set: B, unknown2)"                 , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)"-                , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that "+                , "[__0] skipping: A; 3, 2 (has the same characteristics that "                     ++ "caused the previous version to fail: depends on 'B')"-                , "[__0] trying: A-1.0.0"+                , "[__0] trying: A-1"                 , "[__1] done"                 ]            in setVerbose $@@ -648,16 +670,16 @@                 , Right $ exAv "B" 11 []                 ]               msg =-                [ "[__0] trying: A-4.0.0 (user goal)"+                [ "[__0] trying: A-4 (user goal)"                 , "[__1] next goal: B (dependency of A)"-                , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)"+                , "[__1] rejecting: B-11 (conflict: A => B==14)"                 , "[__1] fail (backjumping, conflict set: A, B)"-                , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that "+                , "[__0] skipping: A; 3, 2 (has the same characteristics that "                     ++ "caused the previous version to fail: depends on 'B' but excludes "-                    ++ "version 11.0.0)"-                , "[__0] trying: A-1.0.0"+                    ++ "version 11)"+                , "[__0] trying: A-1"                 , "[__1] next goal: B (dependency of A)"-                , "[__1] trying: B-11.0.0"+                , "[__1] trying: B-11"                 , "[__2] done"                 ]            in setVerbose $@@ -686,16 +708,16 @@                 ]               goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]               expectedMsg =-                [ "[__0] trying: A-1.0.0 (user goal)"-                , "[__1] trying: B-3.0.0 (dependency of A)"+                [ "[__0] trying: A-1 (user goal)"+                , "[__1] trying: B-3 (dependency of A)"                 , "[__2] next goal: C (dependency of A)"-                , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)"-                , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the "-                    ++ "previous version to fail: excludes 'B' version 3.0.0)"+                , "[__2] rejecting: C-2 (conflict: B==3, C => B==2)"+                , "[__2] skipping: C-1 (has the same characteristics that caused the "+                    ++ "previous version to fail: excludes 'B' version 3)"                 , "[__2] fail (backjumping, conflict set: A, B, C)"-                , "[__1] trying: B-2.0.0"+                , "[__1] trying: B-2"                 , "[__2] next goal: C (dependency of A)"-                , "[__2] trying: C-2.0.0"+                , "[__2] trying: C-2"                 , "[__3] done"                 ]            in setVerbose $@@ -726,22 +748,22 @@                 ]               goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]               msg =-                [ "[__0] trying: A-3.0.0 (user goal)"-                , "[__1] trying: B-1.0.0 (dependency of A)"-                , "[__2] trying: C-1.0.0 (dependency of A)"+                [ "[__0] trying: A-3 (user goal)"+                , "[__1] trying: B-1 (dependency of A)"+                , "[__2] trying: C-1 (dependency of A)"                 , "[__3] next goal: D (dependency of B)"-                , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"-                , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)"+                , "[__3] rejecting: D-2 (conflict: B => D==1)"+                , "[__3] rejecting: D-1 (conflict: C => D==2)"                 , "[__3] fail (backjumping, conflict set: B, C, D)"                 , "[__2] fail (backjumping, conflict set: A, B, C, D)"                 , "[__1] fail (backjumping, conflict set: A, B, C, D)"-                , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the "+                , "[__0] skipping: A-2 (has the same characteristics that caused the "                     ++ "previous version to fail: depends on 'B'; depends on 'C')"-                , "[__0] trying: A-1.0.0"-                , "[__1] trying: B-1.0.0 (dependency of A)"+                , "[__0] trying: A-1"+                , "[__1] trying: B-1 (dependency of A)"                 , "[__2] next goal: D (dependency of B)"-                , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"-                , "[__2] trying: D-1.0.0"+                , "[__2] rejecting: D-2 (conflict: B => D==1)"+                , "[__2] trying: D-1"                 , "[__3] done"                 ]            in setVerbose $@@ -770,18 +792,17 @@                 ]               goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]               msg =-                [ "[__0] trying: A-4.0.0 (user goal)"+                [ "[__0] trying: A-4 (user goal)"                 , "[__1] next goal: B (dependency of A)"-                , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"-                , "[__1] trying: B-1.0.0"+                , "[__1] rejecting: B-2 (conflict: A => B==1)"+                , "[__1] trying: B-1"                 , "[__2] next goal: C (dependency of A)"-                , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)"+                , "[__2] rejecting: C-2 (conflict: A => C==1)"                 , "[__2] fail (backjumping, conflict set: A, C)"-                , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that caused the "-                    ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)"-                , "[__0] trying: A-1.0.0"+                , "[__0] skipping: A; 3, 2 (has the same characteristics that caused the previous version to fail: depends on 'C' but excludes version 2)"+                , "[__0] trying: A-1"                 , "[__1] next goal: C (dependency of A)"-                , "[__1] trying: C-2.0.0"+                , "[__1] trying: C-2"                 , "[__2] done"                 ]            in setVerbose $@@ -800,7 +821,7 @@                 , Right $ exAv "B" 1 []                 ]               msg =-                [ "[__0] trying: A-2.0.0 (user goal)"+                [ "[__0] trying: A-2 (user goal)"                 , "[__1] next goal: B (dependency of A)"                 , -- During this step, the solver adds A and B to the                   -- conflict set, with the details of each package's@@ -808,7 +829,7 @@                   --                   -- A: A's constraint rejected B-2.                   -- B: B was rejected by A's B==3 constraint-                  "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)"+                  "[__1] rejecting: B-2 (conflict: A => B==3)"                 , -- When the solver skips B-1, it cannot simply reuse the                   -- previous conflict set. It also needs to update A's                   -- entry to say that A also rejected B-1. Otherwise, the@@ -816,13 +837,13 @@                   -- the conflicts encountered while exploring A-2. The                   -- solver would skip A-1, even though it leads to the                   -- solution.-                  "[__1] skipping: B-1.0.0 (has the same characteristics that caused "-                    ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')"+                  "[__1] skipping: B-1 (has the same characteristics that caused "+                    ++ "the previous version to fail: excluded by constraint '==3' from 'A')"                 , "[__1] fail (backjumping, conflict set: A, B)"-                , "[__0] trying: A-1.0.0"+                , "[__0] trying: A-1"                 , "[__1] next goal: B (dependency of A)"-                , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"-                , "[__1] trying: B-1.0.0"+                , "[__1] rejecting: B-2 (conflict: A => B==1)"+                , "[__1] trying: B-1"                 , "[__2] done"                 ]            in setVerbose $@@ -841,16 +862,16 @@                 ]               goals = [P QualNone pkg | pkg <- ["A", "B"]]               msg =-                [ "[__0] trying: A-2.0.0 (user goal)"+                [ "[__0] trying: A-2 (user goal)"                 , "[__1] next goal: B (user goal)"-                , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)"-                , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "-                    ++ "the previous version to fail: excludes 'A' version 2.0.0)"+                , "[__1] rejecting: B-2 (conflict: A==2, B => A==3)"+                , "[__1] skipping: B-1 (has the same characteristics that caused "+                    ++ "the previous version to fail: excludes 'A' version 2)"                 , "[__1] fail (backjumping, conflict set: A, B)"-                , "[__0] trying: A-1.0.0"+                , "[__0] trying: A-1"                 , "[__1] next goal: B (user goal)"-                , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)"-                , "[__1] trying: B-1.0.0"+                , "[__1] rejecting: B-2 (conflict: A==1, B => A==3)"+                , "[__1] trying: B-1"                 , "[__2] done"                 ]            in setVerbose $@@ -883,15 +904,15 @@                 solverFailure (isInfixOf msg)       , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $           "Could not resolve dependencies:\n"-            ++ "[__0] trying: A-1.0.0 (user goal)\n"+            ++ "[__0] trying: A-1 (user goal)\n"             ++ "[__1] unknown package: F (dependency of A)\n"             ++ "[__1] fail (backjumping, conflict set: A, F)\n"             ++ "After searching the rest of the dependency tree exhaustively, "             ++ "these were the goals I've had most trouble fulfilling: A, F"       , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $           "Could not resolve dependencies:\n"-            ++ "[__0] trying: A-1.0.0 (user goal)\n"-            ++ "[__1] trying: B-3.0.0 (dependency of A)\n"+            ++ "[__0] trying: A-1 (user goal)\n"+            ++ "[__1] trying: B-3 (dependency of A)\n"             ++ "[__2] unknown package: C (dependency of B)\n"             ++ "[__2] fail (backjumping, conflict set: B, C)\n"             ++ "Backjump limit reached (currently 3, change with --max-backjumps "@@ -907,9 +928,9 @@       , runTest $           let db =                 [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]-                , Left $ exInst "other-package" 2 "other-package-2.0.0" []+                , Left $ exInst "other-package" 2 "other-package-2" []                 ]-              msg = "rejecting: other-package-2.0.0/installed-2.0.0"+              msg = "rejecting: other-package-2/installed-2"            in mkTest db "show full installed package version (issue #5892)" ["my-package"] $                 solverFailure (isInfixOf msg)       , runTest $@@ -917,7 +938,7 @@                 [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]                 , Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" []                 ]-              msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789"+              msg = "rejecting: other-package-2/installed-AbCdEfGhIj0123456789"            in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $                 solverFailure (isInfixOf msg)       , testGroup@@ -928,18 +949,18 @@                     , Right $ exAv "A" 2 []                     , Right $ exAv "B" 1 [ExFix "A" 3]                     ]-                  rejecting = "rejecting: A-2.0.0"-                  skipping = "skipping: A-1.0.0"+                  rejecting = "rejecting: A-2"+                  skipping = "skipping: A-1"                in mkTest db "show skipping singleton" ["B"] $                     solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)           , runTest $               let db =-                    [ Left $ exInst "A" 1 "A-1.0.0" []-                    , Left $ exInst "A" 2 "A-2.0.0" []+                    [ Left $ exInst "A" 1 "A-1" []+                    , Left $ exInst "A" 2 "A-2" []                     , Right $ exAv "B" 1 [ExFix "A" 3]                     ]-                  rejecting = "rejecting: A-2.0.0/installed-2.0.0"-                  skipping = "skipping: A-1.0.0/installed-1.0.0"+                  rejecting = "rejecting: A-2/installed-2"+                  skipping = "skipping: A-1/installed-1"                in mkTest db "show skipping singleton, installed" ["B"] $                     solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)           , runTest $@@ -949,19 +970,19 @@                     , Right $ exAv "A" 3 []                     , Right $ exAv "B" 1 [ExFix "A" 4]                     ]-                  rejecting = "rejecting: A-3.0.0"-                  skipping = "skipping: A; 2.0.0, 1.0.0"+                  rejecting = "rejecting: A-3"+                  skipping = "skipping: A; 2, 1"                in mkTest db "show skipping versions list" ["B"] $                     solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)           , runTest $               let db =-                    [ Left $ exInst "A" 1 "A-1.0.0" []-                    , Left $ exInst "A" 2 "A-2.0.0" []-                    , Left $ exInst "A" 3 "A-3.0.0" []+                    [ Left $ exInst "A" 1 "A-1" []+                    , Left $ exInst "A" 2 "A-2" []+                    , Left $ exInst "A" 3 "A-3" []                     , Right $ exAv "B" 1 [ExFix "A" 4]                     ]-                  rejecting = "rejecting: A-3.0.0/installed-3.0.0"-                  skipping = "skipping: A; 2.0.0/installed-2.0.0, 1.0.0/installed-1.0.0"+                  rejecting = "rejecting: A-3/installed-3"+                  skipping = "skipping: A; 2/installed-2, 1/installed-1"                in mkTest db "show skipping versions list, installed" ["B"] $                     solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)           ]@@ -971,7 +992,7 @@     indep = independentGoals     mkvrThis = V.thisVersion . makeV     mkvrOrEarlier = V.orEarlierVersion . makeV-    makeV v = V.mkVersion [v, 0, 0]+    makeV v = V.mkVersion [v]  data GoalOrder = FixedGoalOrder | DefaultGoalOrder @@ -1388,18 +1409,47 @@             `withSetupDeps` [ExFix "base" 3]       ] +dbBaseOld :: ExampleDb+dbBaseOld = [Right $ exAv "base" 1 []]+ dbBase :: ExampleDb dbBase =   [ Right $       exAv         "base"-        1+        5         [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"]   , Right $ exAv "ghc-prim" 1 []   , Right $ exAv "integer-simple" 1 []   , Right $ exAv "integer-gmp" 1 []   ] +dbTH :: ExampleDb+dbTH =+  -- Base without upperbound will trip the "missing-bounds-important" error. We set the upperbound to a very high upper bound to avoid it.+  let boundedBase = ExRange "base" 0 999+   in [ Right $+          exAv+            "template-haskell"+            1+            [ ExAny "ghc-prim"+            , ExAny "ghc-internal"+            , ExAny "ghc-boot-th"+            , ExAny "pretty"+            , boundedBase+            ]+      , Right $ exAv "ghc-prim" 1 []+      , Left $ exInst "ghc-internal" 1 "ghc-internal-1" []+      , Left $ exInst "ghc-boot-th" 1 "ghc-boot-th-1" []+      , Right $ exAv "pretty" 1 [boundedBase]+      , Right $ exAv "base" 5 [ExAny "ghc-prim", ExAny "ghc-internal"]+      ]++dbGhcInternal :: ExampleDb+dbGhcInternal =+  [ Right $ exAv "ghc-internal" 1 []+  ]+ dbNonupgrade :: ExampleDb dbNonupgrade =   [ Left $ exInst "ghc" 1 "ghc-1" []@@ -1541,7 +1591,7 @@     checkFullLog =       any $         isInfixOf $-          "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "+          "rejecting: time:setup.time~>time-2 (cyclic dependencies; "             ++ "conflict set: time:setup.time)"  -- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack@@ -1572,7 +1622,7 @@      checkSummarizedLog :: String -> Bool     checkSummarizedLog =-      isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"+      isInfixOf "rejecting: pkg-C-1 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"      -- Solve for pkg-D and pkg-E last.     goals :: [ExampleVar]@@ -1718,9 +1768,9 @@   mkTest db name ["A"] $     solverFailure $       isInfixOf $-        "[__0] trying: A-1.0.0 (user goal)\n"+        "[__0] trying: A-1 (user goal)\n"           ++ "[__1] next goal: B (dependency of A +/-flagA)\n"-          ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"+          ++ "[__1] rejecting: B-2 (conflict: A +/-flagA => B==1 || ==3)"   where     db :: ExampleDb     db =@@ -1741,8 +1791,7 @@ twoLevelDeepCommonDependencyLogMessage name =   mkTest db name ["A"] $     solverFailure $-      isInfixOf $-        "unknown package: B (dependency of A +/-flagA +/-flagB)"+      isInfixOf "unknown package: B (dependency of A +/-flagA +/-flagB)"   where     db :: ExampleDb     db =@@ -2021,7 +2070,7 @@ -- If you specify `A == 2`, that top-level should /not/ apply to an independent goal! testIndepGoals7 :: String -> SolverTest testIndepGoals7 name =-  constraints [ExVersionConstraint (scopeToplevel "A") (V.thisVersion (V.mkVersion [2, 0, 0]))] $+  constraints [ExVersionConstraint (scopeToplevel "A") (V.thisVersion (V.mkVersion [2]))] $     independentGoals $       mkTest dbIndepGoals78 name ["A"] $         -- The more recent version should be picked by the solver. As said@@ -2039,7 +2088,7 @@ -- If you specify `any.A == 2`, then that should apply inside an independent goal. testIndepGoals8 :: String -> SolverTest testIndepGoals8 name =-  constraints [ExVersionConstraint (ScopeAnyQualifier "A") (V.thisVersion (V.mkVersion [2, 0, 0]))] $+  constraints [ExVersionConstraint (ScopeAnyQualifier "A") (V.thisVersion (V.mkVersion [2]))] $     independentGoals $       mkTest dbIndepGoals78 name ["A"] $         solverSuccess [("A", 2)]@@ -2197,9 +2246,9 @@      expectedMsg =       "Could not resolve dependencies:\n"-        ++ "[__0] trying: A-3.0.0 (user goal)\n"+        ++ "[__0] trying: A-3 (user goal)\n"         ++ "[__1] next goal: D (dependency of A)\n"-        ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n"+        ++ "[__1] rejecting: D-1 (conflict: A => D==2)\n"         ++ "[__1] fail (backjumping, conflict set: A, D)\n"         ++ "After searching the rest of the dependency tree exhaustively, these "         ++ "were the goals I've had most trouble fulfilling: A (5), D (4)"@@ -2221,9 +2270,9 @@   where     expectedMsg =       "Could not resolve dependencies:\n"-        ++ "[__0] trying: A-3.0.0 (user goal)\n"+        ++ "[__0] trying: A-3 (user goal)\n"         ++ "[__1] next goal: B (dependency of A)\n"-        ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n"+        ++ "[__1] rejecting: B-1 (conflict: A => B==2)\n"         ++ "[__1] fail (backjumping, conflict set: A, B)\n"         ++ "After searching the rest of the dependency tree exhaustively, "         ++ "these were the goals I've had most trouble fulfilling: "@@ -2373,7 +2422,7 @@   mkTest db name ["A"] $     solverFailure $       isInfixOf $-        "rejecting: A:B:exe.B-1.0.0/installed-1 "+        "rejecting: A:B:exe.B-1/installed-1 "           ++ "(does not contain executable 'exe', which is required by A)"   where     db :: ExampleDb@@ -2437,8 +2486,8 @@   mkTest db name ["A"] $     solverFailure $       isInfixOf $-        "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n"-          ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)"+        "[__1] rejecting: A:B:exe.B-2 (conflict: A => A:B:exe.B (exe exe1)==1)\n"+          ++ "[__1] rejecting: A:B:exe.B-1 (conflict: A => A:B:exe.B (exe exe2)==2)"   where     db :: ExampleDb     db =
tests/UnitTests/Options.hs view
@@ -33,7 +33,8 @@ newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int  instance IsOption OptionMtimeChangeDelay where-  defaultValue = OptionMtimeChangeDelay 0+  defaultValue = OptionMtimeChangeDelay 10000+  showDefaultValue (OptionMtimeChangeDelay v) = Just (show v)   parseValue = fmap OptionMtimeChangeDelay . safeRead   optionName = return "mtime-change-delay"   optionHelp =