diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -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 -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 diff --git a/parser-tests/Tests.hs b/parser-tests/Tests.hs new file mode 100644 --- /dev/null +++ b/parser-tests/Tests.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Tasty (defaultMain) +import Tests.ParserTests (parserTests) + +main :: IO () +main = defaultMain parserTests diff --git a/parser-tests/Tests/ParserTests.hs b/parser-tests/Tests/ParserTests.hs new file mode 100644 --- /dev/null +++ b/parser-tests/Tests/ParserTests.hs @@ -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/ + , _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 diff --git a/src/Distribution/Client/BuildReports/Anonymous.hs b/src/Distribution/Client/BuildReports/Anonymous.hs --- a/src/Distribution/Client/BuildReports/Anonymous.hs +++ b/src/Distribution/Client/BuildReports/Anonymous.hs @@ -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 diff --git a/src/Distribution/Client/BuildReports/Storage.hs b/src/Distribution/Client/BuildReports/Storage.hs --- a/src/Distribution/Client/BuildReports/Storage.hs +++ b/src/Distribution/Client/BuildReports/Storage.hs @@ -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 + ] -- ------------------------------------------------------------ diff --git a/src/Distribution/Client/BuildReports/Types.hs b/src/Distribution/Client/BuildReports/Types.hs --- a/src/Distribution/Client/BuildReports/Types.hs +++ b/src/Distribution/Client/BuildReports/Types.hs @@ -39,6 +39,7 @@ deriving (Eq, Ord, Enum, Bounded, Show, Generic) instance Binary ReportLevel +instance NFData ReportLevel instance Structured ReportLevel instance Pretty ReportLevel where diff --git a/src/Distribution/Client/BuildReports/Upload.hs b/src/Distribution/Client/BuildReports/Upload.hs --- a/src/Distribution/Client/BuildReports/Upload.hs +++ b/src/Distribution/Client/BuildReports/Upload.hs @@ -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 diff --git a/src/Distribution/Client/Check.hs b/src/Distribution/Client/Check.hs --- a/src/Distribution/Client/Check.hs +++ b/src/Distribution/Client/Check.hs @@ -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 diff --git a/src/Distribution/Client/CmdClean.hs b/src/Distribution/Client/CmdClean.hs --- a/src/Distribution/Client/CmdClean.hs +++ b/src/Distribution/Client/CmdClean.hs @@ -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 diff --git a/src/Distribution/Client/CmdConfigure.hs b/src/Distribution/Client/CmdConfigure.hs --- a/src/Distribution/Client/CmdConfigure.hs +++ b/src/Distribution/Client/CmdConfigure.hs @@ -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 diff --git a/src/Distribution/Client/CmdExec.hs b/src/Distribution/Client/CmdExec.hs --- a/src/Distribution/Client/CmdExec.hs +++ b/src/Distribution/Client/CmdExec.hs @@ -250,7 +250,6 @@ let tmpDirTemplate = distTempDirectory (distDirLayout baseCtx) createDirectoryIfMissingVerbose verbosity True tmpDirTemplate withTempDirectory - verbosity tmpDirTemplate "environment." ( \tmpDir -> do diff --git a/src/Distribution/Client/CmdFreeze.hs b/src/Distribution/Client/CmdFreeze.hs --- a/src/Distribution/Client/CmdFreeze.hs +++ b/src/Distribution/Client/CmdFreeze.hs @@ -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 = diff --git a/src/Distribution/Client/CmdGenBounds.hs b/src/Distribution/Client/CmdGenBounds.hs --- a/src/Distribution/Client/CmdGenBounds.hs +++ b/src/Distribution/Client/CmdGenBounds.hs @@ -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. diff --git a/src/Distribution/Client/CmdHaddockProject.hs b/src/Distribution/Client/CmdHaddockProject.hs --- a/src/Distribution/Client/CmdHaddockProject.hs +++ b/src/Distribution/Client/CmdHaddockProject.hs @@ -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 diff --git a/src/Distribution/Client/CmdInstall.hs b/src/Distribution/Client/CmdInstall.hs --- a/src/Distribution/Client/CmdInstall.hs +++ b/src/Distribution/Client/CmdInstall.hs @@ -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 diff --git a/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs --- a/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -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 #-} diff --git a/src/Distribution/Client/CmdLegacy.hs b/src/Distribution/Client/CmdLegacy.hs --- a/src/Distribution/Client/CmdLegacy.hs +++ b/src/Distribution/Client/CmdLegacy.hs @@ -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 = diff --git a/src/Distribution/Client/CmdListBin.hs b/src/Distribution/Client/CmdListBin.hs --- a/src/Distribution/Client/CmdListBin.hs +++ b/src/Distribution/Client/CmdListBin.hs @@ -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) = diff --git a/src/Distribution/Client/CmdOutdated.hs b/src/Distribution/Client/CmdOutdated.hs --- a/src/Distribution/Client/CmdOutdated.hs +++ b/src/Distribution/Client/CmdOutdated.hs @@ -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' diff --git a/src/Distribution/Client/CmdPath.hs b/src/Distribution/Client/CmdPath.hs --- a/src/Distribution/Client/CmdPath.hs +++ b/src/Distribution/Client/CmdPath.hs @@ -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 diff --git a/src/Distribution/Client/CmdRepl.hs b/src/Distribution/Client/CmdRepl.hs --- a/src/Distribution/Client/CmdRepl.hs +++ b/src/Distribution/Client/CmdRepl.hs @@ -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, diff --git a/src/Distribution/Client/CmdRun.hs b/src/Distribution/Client/CmdRun.hs --- a/src/Distribution/Client/CmdRun.hs +++ b/src/Distribution/Client/CmdRun.hs @@ -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 diff --git a/src/Distribution/Client/CmdSdist.hs b/src/Distribution/Client/CmdSdist.hs --- a/src/Distribution/Client/CmdSdist.hs +++ b/src/Distribution/Client/CmdSdist.hs @@ -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 diff --git a/src/Distribution/Client/CmdTarget.hs b/src/Distribution/Client/CmdTarget.hs --- a/src/Distribution/Client/CmdTarget.hs +++ b/src/Distribution/Client/CmdTarget.hs @@ -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 diff --git a/src/Distribution/Client/CmdTest.hs b/src/Distribution/Client/CmdTest.hs --- a/src/Distribution/Client/CmdTest.hs +++ b/src/Distribution/Client/CmdTest.hs @@ -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 diff --git a/src/Distribution/Client/CmdUpdate.hs b/src/Distribution/Client/CmdUpdate.hs --- a/src/Distribution/Client/CmdUpdate.hs +++ b/src/Distribution/Client/CmdUpdate.hs @@ -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 [,] 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) ++ "." diff --git a/src/Distribution/Client/Compat/Directory.hs b/src/Distribution/Client/Compat/Directory.hs deleted file mode 100644 --- a/src/Distribution/Client/Compat/Directory.hs +++ /dev/null @@ -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 diff --git a/src/Distribution/Client/Compat/ExecutablePath.hs b/src/Distribution/Client/Compat/ExecutablePath.hs deleted file mode 100644 --- a/src/Distribution/Client/Compat/ExecutablePath.hs +++ /dev/null @@ -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 -} diff --git a/src/Distribution/Client/Config.hs b/src/Distribution/Client/Config.hs --- a/src/Distribution/Client/Config.hs +++ b/src/Distribution/Client/Config.hs @@ -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 diff --git a/src/Distribution/Client/Configure.hs b/src/Distribution/Client/Configure.hs --- a/src/Distribution/Client/Configure.hs +++ b/src/Distribution/Client/Configure.hs @@ -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 = diff --git a/src/Distribution/Client/Dependency.hs b/src/Distribution/Client/Dependency.hs --- a/src/Distribution/Client/Dependency.hs +++ b/src/Distribution/Client/Dependency.hs @@ -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] diff --git a/src/Distribution/Client/Dependency/Types.hs b/src/Distribution/Client/Dependency/Types.hs --- a/src/Distribution/Client/Dependency/Types.hs +++ b/src/Distribution/Client/Dependency/Types.hs @@ -24,6 +24,8 @@ instance Binary PreSolver instance Binary Solver +instance NFData PreSolver + instance Structured PreSolver instance Structured Solver diff --git a/src/Distribution/Client/DistDirLayout.hs b/src/Distribution/Client/DistDirLayout.hs --- a/src/Distribution/Client/DistDirLayout.hs +++ b/src/Distribution/Client/DistDirLayout.hs @@ -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 diff --git a/src/Distribution/Client/Errors.hs b/src/Distribution/Client/Errors.hs --- a/src/Distribution/Client/Errors.hs +++ b/src/Distribution/Client/Errors.hs @@ -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] diff --git a/src/Distribution/Client/Errors/Parser.hs b/src/Distribution/Client/Errors/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Errors/Parser.hs @@ -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' diff --git a/src/Distribution/Client/Fetch.hs b/src/Distribution/Client/Fetch.hs --- a/src/Distribution/Client/Fetch.hs +++ b/src/Distribution/Client/Fetch.hs @@ -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 diff --git a/src/Distribution/Client/FetchUtils.hs b/src/Distribution/Client/FetchUtils.hs --- a/src/Distribution/Client/FetchUtils.hs +++ b/src/Distribution/Client/FetchUtils.hs @@ -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) <- diff --git a/src/Distribution/Client/FileMonitor.hs b/src/Distribution/Client/FileMonitor.hs --- a/src/Distribution/Client/FileMonitor.hs +++ b/src/Distribution/Client/FileMonitor.hs @@ -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 = [] diff --git a/src/Distribution/Client/Freeze.hs b/src/Distribution/Client/Freeze.hs --- a/src/Distribution/Client/Freeze.hs +++ b/src/Distribution/Client/Freeze.hs @@ -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 = diff --git a/src/Distribution/Client/GZipUtils.hs b/src/Distribution/Client/GZipUtils.hs --- a/src/Distribution/Client/GZipUtils.hs +++ b/src/Distribution/Client/GZipUtils.hs @@ -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: -- 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 diff --git a/src/Distribution/Client/Get.hs b/src/Distribution/Client/Get.hs --- a/src/Distribution/Client/Get.hs +++ b/src/Distribution/Client/Get.hs @@ -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 diff --git a/src/Distribution/Client/GlobalFlags.hs b/src/Distribution/Client/GlobalFlags.hs --- a/src/Distribution/Client/GlobalFlags.hs +++ b/src/Distribution/Client/GlobalFlags.hs @@ -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 } diff --git a/src/Distribution/Client/Haddock.hs b/src/Distribution/Client/Haddock.hs --- a/src/Distribution/Client/Haddock.hs +++ b/src/Distribution/Client/Haddock.hs @@ -66,7 +66,7 @@ createDirectoryIfMissing True destDir - withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + withTempDirectory destDir "tmphaddock" $ \tempDir -> do let flags = [ "--gen-contents" , "--gen-index" diff --git a/src/Distribution/Client/HashValue.hs b/src/Distribution/Client/HashValue.hs --- a/src/Distribution/Client/HashValue.hs +++ b/src/Distribution/Client/HashValue.hs @@ -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 -- diff --git a/src/Distribution/Client/HttpUtils.hs b/src/Distribution/Client/HttpUtils.hs --- a/src/Distribution/Client/HttpUtils.hs +++ b/src/Distribution/Client/HttpUtils.hs @@ -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 = diff --git a/src/Distribution/Client/InLibrary.hs b/src/Distribution/Client/InLibrary.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/InLibrary.hs @@ -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 diff --git a/src/Distribution/Client/IndexUtils.hs b/src/Distribution/Client/IndexUtils.hs --- a/src/Distribution/Client/IndexUtils.hs +++ b/src/Distribution/Client/IndexUtils.hs @@ -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 diff --git a/src/Distribution/Client/IndexUtils/ActiveRepos.hs b/src/Distribution/Client/IndexUtils/ActiveRepos.hs --- a/src/Distribution/Client/IndexUtils/ActiveRepos.hs +++ b/src/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -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 diff --git a/src/Distribution/Client/Init.hs b/src/Distribution/Client/Init.hs --- a/src/Distribution/Client/Init.hs +++ b/src/Distribution/Client/Init.hs @@ -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 diff --git a/src/Distribution/Client/Init/Defaults.hs b/src/Distribution/Client/Init/Defaults.hs --- a/src/Distribution/Client/Init/Defaults.hs +++ b/src/Distribution/Client/Init/Defaults.hs @@ -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 diff --git a/src/Distribution/Client/Init/FileCreators.hs b/src/Distribution/Client/Init/FileCreators.hs --- a/src/Distribution/Client/Init/FileCreators.hs +++ b/src/Distribution/Client/Init/FileCreators.hs @@ -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. diff --git a/src/Distribution/Client/Init/FlagExtractors.hs b/src/Distribution/Client/Init/FlagExtractors.hs --- a/src/Distribution/Client/Init/FlagExtractors.hs +++ b/src/Distribution/Client/Init/FlagExtractors.hs @@ -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. diff --git a/src/Distribution/Client/Init/Format.hs b/src/Distribution/Client/Init/Format.hs --- a/src/Distribution/Client/Init/Format.hs +++ b/src/Distribution/Client/Init/Format.hs @@ -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" diff --git a/src/Distribution/Client/Init/Interactive/Command.hs b/src/Distribution/Client/Init/Interactive/Command.hs --- a/src/Distribution/Client/Init/Interactive/Command.hs +++ b/src/Distribution/Client/Init/Interactive/Command.hs @@ -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 diff --git a/src/Distribution/Client/Init/NonInteractive/Command.hs b/src/Distribution/Client/Init/NonInteractive/Command.hs --- a/src/Distribution/Client/Init/NonInteractive/Command.hs +++ b/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -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] diff --git a/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/src/Distribution/Client/Init/NonInteractive/Heuristics.hs --- a/src/Distribution/Client/Init/NonInteractive/Heuristics.hs +++ b/src/Distribution/Client/Init/NonInteractive/Heuristics.hs @@ -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) diff --git a/src/Distribution/Client/Init/Prompt.hs b/src/Distribution/Client/Init/Prompt.hs --- a/src/Distribution/Client/Init/Prompt.hs +++ b/src/Distribution/Client/Init/Prompt.hs @@ -152,7 +152,7 @@ -- ^ pretty-printer -> String -- ^ prompt message - -> (DefaultPrompt t) + -> DefaultPrompt t -- ^ optional default value -> m t promptDefault parse pprint msg def = do diff --git a/src/Distribution/Client/Init/Simple.hs b/src/Distribution/Client/Init/Simple.hs --- a/src/Distribution/Client/Init/Simple.hs +++ b/src/Distribution/Client/Init/Simple.hs @@ -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 diff --git a/src/Distribution/Client/Init/Types.hs b/src/Distribution/Client/Init/Types.hs --- a/src/Distribution/Client/Init/Types.hs +++ b/src/Distribution/Client/Init/Types.hs @@ -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 diff --git a/src/Distribution/Client/Init/Utils.hs b/src/Distribution/Client/Init/Utils.hs --- a/src/Distribution/Client/Init/Utils.hs +++ b/src/Distribution/Client/Init/Utils.hs @@ -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 diff --git a/src/Distribution/Client/Install.hs b/src/Distribution/Client/Install.hs --- a/src/Distribution/Client/Install.hs +++ b/src/Distribution/Client/Install.hs @@ -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 diff --git a/src/Distribution/Client/InstallPlan.hs b/src/Distribution/Client/InstallPlan.hs --- a/src/Distribution/Client/InstallPlan.hs +++ b/src/Distribution/Client/InstallPlan.hs @@ -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') ] diff --git a/src/Distribution/Client/InstallSymlink.hs b/src/Distribution/Client/InstallSymlink.hs --- a/src/Distribution/Client/InstallSymlink.hs +++ b/src/Distribution/Client/InstallSymlink.hs @@ -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 diff --git a/src/Distribution/Client/JobControl.hs b/src/Distribution/Client/JobControl.hs --- a/src/Distribution/Client/JobControl.hs +++ b/src/Distribution/Client/JobControl.hs @@ -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 diff --git a/src/Distribution/Client/List.hs b/src/Distribution/Client/List.hs --- a/src/Distribution/Client/List.hs +++ b/src/Distribution/Client/List.hs @@ -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 diff --git a/src/Distribution/Client/Main.hs b/src/Distribution/Client/Main.hs --- a/src/Distribution/Client/Main.hs +++ b/src/Distribution/Client/Main.hs @@ -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} diff --git a/src/Distribution/Client/Manpage.hs b/src/Distribution/Client/Manpage.hs --- a/src/Distribution/Client/Manpage.hs +++ b/src/Distribution/Client/Manpage.hs @@ -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 , "" diff --git a/src/Distribution/Client/ManpageFlags.hs b/src/Distribution/Client/ManpageFlags.hs --- a/src/Distribution/Client/ManpageFlags.hs +++ b/src/Distribution/Client/ManpageFlags.hs @@ -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) diff --git a/src/Distribution/Client/Nix.hs b/src/Distribution/Client/Nix.hs deleted file mode 100644 --- a/src/Distribution/Client/Nix.hs +++ /dev/null @@ -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 diff --git a/src/Distribution/Client/NixStyleOptions.hs b/src/Distribution/Client/NixStyleOptions.hs --- a/src/Distribution/Client/NixStyleOptions.hs +++ b/src/Distribution/Client/NixStyleOptions.hs @@ -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) diff --git a/src/Distribution/Client/PackageHash.hs b/src/Distribution/Client/PackageHash.hs --- a/src/Distribution/Client/PackageHash.hs +++ b/src/Distribution/Client/PackageHash.hs @@ -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 diff --git a/src/Distribution/Client/ParseUtils.hs b/src/Distribution/Client/ParseUtils.hs --- a/src/Distribution/Client/ParseUtils.hs +++ b/src/Distribution/Client/ParseUtils.hs @@ -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 diff --git a/src/Distribution/Client/ProjectBuilding.hs b/src/Distribution/Client/ProjectBuilding.hs --- a/src/Distribution/Client/ProjectBuilding.hs +++ b/src/Distribution/Client/ProjectBuilding.hs @@ -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 diff --git a/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs --- a/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs +++ b/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs @@ -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) diff --git a/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs --- a/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -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 diff --git a/src/Distribution/Client/ProjectConfig.hs b/src/Distribution/Client/ProjectConfig.hs --- a/src/Distribution/Client/ProjectConfig.hs +++ b/src/Distribution/Client/ProjectConfig.hs @@ -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. diff --git a/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/src/Distribution/Client/ProjectConfig/FieldGrammar.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -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 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." diff --git a/src/Distribution/Client/ProjectConfig/Import.hs b/src/Distribution/Client/ProjectConfig/Import.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig/Import.hs @@ -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) diff --git a/src/Distribution/Client/ProjectConfig/Legacy.hs b/src/Distribution/Client/ProjectConfig/Legacy.hs --- a/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -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 diff --git a/src/Distribution/Client/ProjectConfig/Lens.hs b/src/Distribution/Client/ProjectConfig/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig/Lens.hs @@ -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 #-} diff --git a/src/Distribution/Client/ProjectConfig/Parsec.hs b/src/Distribution/Client/ProjectConfig/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -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 "" (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 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 "" 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 diff --git a/src/Distribution/Client/ProjectConfig/Types.hs b/src/Distribution/Client/ProjectConfig/Types.hs --- a/src/Distribution/Client/ProjectConfig/Types.hs +++ b/src/Distribution/Client/ProjectConfig/Types.hs @@ -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 diff --git a/src/Distribution/Client/ProjectFlags.hs b/src/Distribution/Client/ProjectFlags.hs --- a/src/Distribution/Client/ProjectFlags.hs +++ b/src/Distribution/Client/ProjectFlags.hs @@ -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 diff --git a/src/Distribution/Client/ProjectOrchestration.hs b/src/Distribution/Client/ProjectOrchestration.hs --- a/src/Distribution/Client/ProjectOrchestration.hs +++ b/src/Distribution/Client/ProjectOrchestration.hs @@ -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 " diff --git a/src/Distribution/Client/ProjectPlanOutput.hs b/src/Distribution/Client/ProjectPlanOutput.hs --- a/src/Distribution/Client/ProjectPlanOutput.hs +++ b/src/Distribution/Client/ProjectPlanOutput.hs @@ -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. -- diff --git a/src/Distribution/Client/ProjectPlanning.hs b/src/Distribution/Client/ProjectPlanning.hs --- a/src/Distribution/Client/ProjectPlanning.hs +++ b/src/Distribution/Client/ProjectPlanning.hs @@ -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 + -- + -- 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 + -- + -- (see also ) + -- + -- 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 - -- - -- 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 - -- - -- (see also ) - -- - -- 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 diff --git a/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs b/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs --- a/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs +++ b/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs @@ -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] diff --git a/src/Distribution/Client/ProjectPlanning/Types.hs b/src/Distribution/Client/ProjectPlanning/Types.hs --- a/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/src/Distribution/Client/ProjectPlanning/Types.hs @@ -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" diff --git a/src/Distribution/Client/RebuildMonad.hs b/src/Distribution/Client/RebuildMonad.hs --- a/src/Distribution/Client/RebuildMonad.hs +++ b/src/Distribution/Client/RebuildMonad.hs @@ -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 ] diff --git a/src/Distribution/Client/Reconfigure.hs b/src/Distribution/Client/Reconfigure.hs --- a/src/Distribution/Client/Reconfigure.hs +++ b/src/Distribution/Client/Reconfigure.hs @@ -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)) diff --git a/src/Distribution/Client/Run.hs b/src/Distribution/Client/Run.hs --- a/src/Distribution/Client/Run.hs +++ b/src/Distribution/Client/Run.hs @@ -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) diff --git a/src/Distribution/Client/Sandbox.hs b/src/Distribution/Client/Sandbox.hs --- a/src/Distribution/Client/Sandbox.hs +++ b/src/Distribution/Client/Sandbox.hs @@ -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' diff --git a/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/src/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/src/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -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 = diff --git a/src/Distribution/Client/SavedFlags.hs b/src/Distribution/Client/SavedFlags.hs --- a/src/Distribution/Client/SavedFlags.hs +++ b/src/Distribution/Client/SavedFlags.hs @@ -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 diff --git a/src/Distribution/Client/ScriptUtils.hs b/src/Distribution/Client/ScriptUtils.hs --- a/src/Distribution/Client/ScriptUtils.hs +++ b/src/Distribution/Client/ScriptUtils.hs @@ -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 diff --git a/src/Distribution/Client/Security/HTTP.hs b/src/Distribution/Client/Security/HTTP.hs --- a/src/Distribution/Client/Security/HTTP.hs +++ b/src/Distribution/Client/Security/HTTP.hs @@ -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) diff --git a/src/Distribution/Client/Setup.hs b/src/Distribution/Client/Setup.hs --- a/src/Distribution/Client/Setup.hs +++ b/src/Distribution/Client/Setup.hs @@ -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] } diff --git a/src/Distribution/Client/SetupWrapper.hs b/src/Distribution/Client/SetupWrapper.hs --- a/src/Distribution/Client/SetupWrapper.hs +++ b/src/Distribution/Client/SetupWrapper.hs @@ -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 +-------------------------------------------------------------------------------- diff --git a/src/Distribution/Client/SolverInstallPlan.hs b/src/Distribution/Client/SolverInstallPlan.hs --- a/src/Distribution/Client/SolverInstallPlan.hs +++ b/src/Distribution/Client/SolverInstallPlan.hs @@ -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') ] diff --git a/src/Distribution/Client/SourceFiles.hs b/src/Distribution/Client/SourceFiles.hs --- a/src/Distribution/Client/SourceFiles.hs +++ b/src/Distribution/Client/SourceFiles.hs @@ -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 = diff --git a/src/Distribution/Client/SrcDist.hs b/src/Distribution/Client/SrcDist.hs --- a/src/Distribution/Client/SrcDist.hs +++ b/src/Distribution/Client/SrcDist.hs @@ -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 diff --git a/src/Distribution/Client/Store.hs b/src/Distribution/Client/Store.hs --- a/src/Distribution/Client/Store.hs +++ b/src/Distribution/Client/Store.hs @@ -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 diff --git a/src/Distribution/Client/Tar.hs b/src/Distribution/Client/Tar.hs --- a/src/Distribution/Client/Tar.hs +++ b/src/Distribution/Client/Tar.hs @@ -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 diff --git a/src/Distribution/Client/TargetSelector.hs b/src/Distribution/Client/TargetSelector.hs --- a/src/Distribution/Client/TargetSelector.hs +++ b/src/Distribution/Client/TargetSelector.hs @@ -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] diff --git a/src/Distribution/Client/Targets.hs b/src/Distribution/Client/Targets.hs --- a/src/Distribution/Client/Targets.hs +++ b/src/Distribution/Client/Targets.hs @@ -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 diff --git a/src/Distribution/Client/Types/AllowNewer.hs b/src/Distribution/Client/Types/AllowNewer.hs --- a/src/Distribution/Client/Types/AllowNewer.hs +++ b/src/Distribution/Client/Types/AllowNewer.hs @@ -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 diff --git a/src/Distribution/Client/Types/ConfiguredPackage.hs b/src/Distribution/Client/Types/ConfiguredPackage.hs --- a/src/Distribution/Client/Types/ConfiguredPackage.hs +++ b/src/Distribution/Client/Types/ConfiguredPackage.hs @@ -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 diff --git a/src/Distribution/Client/Types/InstallMethod.hs b/src/Distribution/Client/Types/InstallMethod.hs --- a/src/Distribution/Client/Types/InstallMethod.hs +++ b/src/Distribution/Client/Types/InstallMethod.hs @@ -14,6 +14,7 @@ deriving (Eq, Show, Generic, Bounded, Enum) instance Binary InstallMethod +instance NFData InstallMethod instance Structured InstallMethod -- | Last diff --git a/src/Distribution/Client/Types/OverwritePolicy.hs b/src/Distribution/Client/Types/OverwritePolicy.hs --- a/src/Distribution/Client/Types/OverwritePolicy.hs +++ b/src/Distribution/Client/Types/OverwritePolicy.hs @@ -15,6 +15,7 @@ deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy +instance NFData OverwritePolicy instance Structured OverwritePolicy instance Parsec OverwritePolicy where diff --git a/src/Distribution/Client/Types/PackageLocation.hs b/src/Distribution/Client/Types/PackageLocation.hs --- a/src/Distribution/Client/Types/PackageLocation.hs +++ b/src/Distribution/Client/Types/PackageLocation.hs @@ -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) diff --git a/src/Distribution/Client/Types/PackageSpecifier.hs b/src/Distribution/Client/Types/PackageSpecifier.hs --- a/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/src/Distribution/Client/Types/PackageSpecifier.hs @@ -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] diff --git a/src/Distribution/Client/Types/Repo.hs b/src/Distribution/Client/Types/Repo.hs --- a/src/Distribution/Client/Types/Repo.hs +++ b/src/Distribution/Client/Types/Repo.hs @@ -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] diff --git a/src/Distribution/Client/Types/SourceRepo.hs b/src/Distribution/Client/Types/SourceRepo.hs --- a/src/Distribution/Client/Types/SourceRepo.hs +++ b/src/Distribution/Client/Types/SourceRepo.hs @@ -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) diff --git a/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs --- a/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs +++ b/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs @@ -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 + <> "'" diff --git a/src/Distribution/Client/Upload.hs b/src/Distribution/Client/Upload.hs --- a/src/Distribution/Client/Upload.hs +++ b/src/Distribution/Client/Upload.hs @@ -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) diff --git a/src/Distribution/Client/Utils.hs b/src/Distribution/Client/Utils.hs --- a/src/Distribution/Client/Utils.hs +++ b/src/Distribution/Client/Utils.hs @@ -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 diff --git a/src/Distribution/Client/Utils/Newtypes.hs b/src/Distribution/Client/Utils/Newtypes.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Utils/Newtypes.hs @@ -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 diff --git a/src/Distribution/Client/Utils/Parsec.hs b/src/Distribution/Client/Utils/Parsec.hs --- a/src/Distribution/Client/Utils/Parsec.hs +++ b/src/Distribution/Client/Utils/Parsec.hs @@ -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 diff --git a/src/Distribution/Client/VCS.hs b/src/Distribution/Client/VCS.hs --- a/src/Distribution/Client/VCS.hs +++ b/src/Distribution/Client/VCS.hs @@ -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 == '.' diff --git a/src/Distribution/Client/Version.hs b/src/Distribution/Client/Version.hs --- a/src/Distribution/Client/Version.hs +++ b/src/Distribution/Client/Version.hs @@ -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 diff --git a/src/Distribution/Client/Win32SelfUpgrade.hs b/src/Distribution/Client/Win32SelfUpgrade.hs --- a/src/Distribution/Client/Win32SelfUpgrade.hs +++ b/src/Distribution/Client/Win32SelfUpgrade.hs @@ -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 -} diff --git a/src/Distribution/Deprecated/ParseUtils.hs b/src/Distribution/Deprecated/ParseUtils.hs --- a/src/Distribution/Deprecated/ParseUtils.hs +++ b/src/Distribution/Deprecated/ParseUtils.hs @@ -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 diff --git a/src/Distribution/Deprecated/ReadP.hs b/src/Distribution/Deprecated/ReadP.hs --- a/src/Distribution/Deprecated/ReadP.hs +++ b/src/Distribution/Deprecated/ReadP.hs @@ -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/ --- (). --- --- This version of ReadP has been locally hacked to make it H98, by --- Martin Sjögren --- --- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by --- Mark Lentczner +-- 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 diff --git a/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/src/Distribution/Deprecated/ViewAsFieldDescr.hs --- a/src/Distribution/Deprecated/ViewAsFieldDescr.hs +++ b/src/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -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 ("" ++) parsec) val - OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + BoolOpt _ _ _ setV _ -> (`setV` a) <$> runE line n (parsecToReadE ("" ++) parsec) val + OptArg _ _ _ readE _ _ -> ($ a) <$> runE line n readE val -- Optional arguments are parsed just like -- required arguments here; we don't diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs --- a/tests/IntegrationTests2.hs +++ b/tests/IntegrationTests2.hs @@ -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 diff --git a/tests/IntegrationTests2/CPP.hs b/tests/IntegrationTests2/CPP.hs deleted file mode 100644 --- a/tests/IntegrationTests2/CPP.hs +++ /dev/null @@ -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 diff --git a/tests/LongTests.hs b/tests/LongTests.hs --- a/tests/LongTests.hs +++ b/tests/LongTests.hs @@ -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 + ] diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs --- a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -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 [] = [] diff --git a/tests/UnitTests/Distribution/Client/Configure.hs b/tests/UnitTests/Distribution/Client/Configure.hs --- a/tests/UnitTests/Distribution/Client/Configure.hs +++ b/tests/UnitTests/Distribution/Client/Configure.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/DescribedInstances.hs b/tests/UnitTests/Distribution/Client/DescribedInstances.hs --- a/tests/UnitTests/Distribution/Client/DescribedInstances.hs +++ b/tests/UnitTests/Distribution/Client/DescribedInstances.hs @@ -92,7 +92,7 @@ instance Described RelaxedDep where describe _ = - REOpt (describeRelaxDepScope <> ":" <> REOpt ("^")) + REOpt (describeRelaxDepScope <> ":" <> REOpt "^") <> describe (Proxy :: Proxy RelaxDepSubject) where describeRelaxDepScope = diff --git a/tests/UnitTests/Distribution/Client/FetchUtils.hs b/tests/UnitTests/Distribution/Client/FetchUtils.hs --- a/tests/UnitTests/Distribution/Client/FetchUtils.hs +++ b/tests/UnitTests/Distribution/Client/FetchUtils.hs @@ -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. diff --git a/tests/UnitTests/Distribution/Client/FileMonitor.hs b/tests/UnitTests/Distribution/Client/FileMonitor.hs --- a/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/GZipUtils.hs b/tests/UnitTests/Distribution/Client/GZipUtils.hs --- a/tests/UnitTests/Distribution/Client/GZipUtils.hs +++ b/tests/UnitTests/Distribution/Client/GZipUtils.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/Get.hs b/tests/UnitTests/Distribution/Client/Get.hs --- a/tests/UnitTests/Distribution/Client/Get.hs +++ b/tests/UnitTests/Distribution/Client/Get.hs @@ -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) diff --git a/tests/UnitTests/Distribution/Client/Glob.hs b/tests/UnitTests/Distribution/Client/Glob.hs --- a/tests/UnitTests/Distribution/Client/Glob.hs +++ b/tests/UnitTests/Distribution/Client/Glob.hs @@ -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]) <- diff --git a/tests/UnitTests/Distribution/Client/IndexUtils.hs b/tests/UnitTests/Distribution/Client/IndexUtils.hs --- a/tests/UnitTests/Distribution/Client/IndexUtils.hs +++ b/tests/UnitTests/Distribution/Client/IndexUtils.hs @@ -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) diff --git a/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs b/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/Init.hs b/tests/UnitTests/Distribution/Client/Init.hs --- a/tests/UnitTests/Distribution/Client/Init.hs +++ b/tests/UnitTests/Distribution/Client/Init.hs @@ -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} diff --git a/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/tests/UnitTests/Distribution/Client/Init/FileCreators.hs --- a/tests/UnitTests/Distribution/Client/Init/FileCreators.hs +++ b/tests/UnitTests/Distribution/Client/Init/FileCreators.hs @@ -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 () diff --git a/tests/UnitTests/Distribution/Client/Init/Golden.hs b/tests/UnitTests/Distribution/Client/Init/Golden.hs --- a/tests/UnitTests/Distribution/Client/Init/Golden.hs +++ b/tests/UnitTests/Distribution/Client/Init/Golden.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/tests/UnitTests/Distribution/Client/Init/Interactive.hs --- a/tests/UnitTests/Distribution/Client/Init/Interactive.hs +++ b/tests/UnitTests/Distribution/Client/Init/Interactive.hs @@ -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) diff --git a/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs --- a/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs +++ b/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -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"] diff --git a/tests/UnitTests/Distribution/Client/Init/Simple.hs b/tests/UnitTests/Distribution/Client/Init/Simple.hs --- a/tests/UnitTests/Distribution/Client/Init/Simple.hs +++ b/tests/UnitTests/Distribution/Client/Init/Simple.hs @@ -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 = diff --git a/tests/UnitTests/Distribution/Client/InstallPlan.hs b/tests/UnitTests/Distribution/Client/InstallPlan.hs --- a/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/tests/UnitTests/Distribution/Client/ProjectConfig.hs --- a/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/Store.hs b/tests/UnitTests/Distribution/Client/Store.hs --- a/tests/UnitTests/Distribution/Client/Store.hs +++ b/tests/UnitTests/Distribution/Client/Store.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/Tar.hs b/tests/UnitTests/Distribution/Client/Tar.hs --- a/tests/UnitTests/Distribution/Client/Tar.hs +++ b/tests/UnitTests/Distribution/Client/Tar.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs --- a/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Client/UserConfig.hs b/tests/UnitTests/Distribution/Client/UserConfig.hs --- a/tests/UnitTests/Distribution/Client/UserConfig.hs +++ b/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -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"] diff --git a/tests/UnitTests/Distribution/Client/VCS.hs b/tests/UnitTests/Distribution/Client/VCS.hs --- a/tests/UnitTests/Distribution/Client/VCS.hs +++ b/tests/UnitTests/Distribution/Client/VCS.hs @@ -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] diff --git a/tests/UnitTests/Distribution/Solver/Modular/Builder.hs b/tests/UnitTests/Distribution/Solver/Modular/Builder.hs --- a/tests/UnitTests/Distribution/Solver/Modular/Builder.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/Builder.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs --- a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs --- a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs --- a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -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" diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs --- a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs --- a/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs --- a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -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 = diff --git a/tests/UnitTests/Options.hs b/tests/UnitTests/Options.hs --- a/tests/UnitTests/Options.hs +++ b/tests/UnitTests/Options.hs @@ -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 =