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.0 Name: cabal-install -Version: 3.12.1.0 +Version: 3.14.1.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -40,27 +40,28 @@ manual: True common warnings - ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates + ghc-options: + -Wall + -Wcompat + -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-unticked-promoted-constructors if impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances - if impl(ghc >=9.0) - -- Warning: even though introduced with GHC 8.10, -Wunused-packages - -- gives false positives with GHC 8.10. - ghc-options: -Wunused-packages - common base-dep - build-depends: base >=4.11 && <4.21 + build-depends: base >=4.13 && <4.22 common cabal-dep - build-depends: Cabal ^>=3.12.1.0 + build-depends: Cabal ^>=3.14 common cabal-syntax-dep - build-depends: Cabal-syntax ^>=3.12.1.0 + build-depends: Cabal-syntax ^>=3.14 common cabal-install-solver-dep - build-depends: cabal-install-solver ^>=3.12.1.0 + build-depends: cabal-install-solver ^>=3.14 library import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep @@ -230,7 +231,6 @@ edit-distance >= 0.2.2 && < 0.3, exceptions >= 0.10.4 && < 0.11, filepath >= 1.4.0.0 && < 1.6, - hashable >= 1.0 && < 1.5, HTTP >= 4000.1.5 && < 4000.5, mtl >= 2.0 && < 2.4, network-uri >= 2.6.0.2 && < 2.7, @@ -241,7 +241,7 @@ tar >= 0.5.0.3 && < 0.7, time >= 1.5.0.1 && < 1.15, zlib >= 0.5.3 && < 0.8, - hackage-security >= 0.6.2.6 && < 0.7, + 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.3, @@ -349,7 +349,7 @@ zlib, tasty >= 1.2.3 && <1.6, tasty-golden >=2.3.1.1 && <2.4, - tasty-quickcheck <0.11, + tasty-quickcheck ^>=0.11, tasty-expected-failure, tasty-hunit >= 0.10, tree-diff, @@ -398,6 +398,7 @@ containers, directory, filepath, + process, tasty >= 1.2.3 && <1.6, tasty-hunit >= 0.10, tagged @@ -429,7 +430,6 @@ containers, directory, filepath, - hashable, mtl, network-uri >= 2.6.2.0 && <2.7, random, @@ -437,6 +437,6 @@ tasty >= 1.2.3 && <1.6, tasty-expected-failure, tasty-hunit >= 0.10, - tasty-quickcheck <0.11, + tasty-quickcheck <0.12, QuickCheck >= 2.14 && <2.16, pretty-show >= 1.6.15 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,9 +1,14 @@ -*-change-log-*- +3.14.1.0 Hécate November 2024 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.14.1.0.md + +3.14.0.0 Hécate September 2024 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.14.0.0.md + 3.12.1.0 Artem Pelenitsyn June 2024 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.12.1.0.md -3.10.2.0 Hécate August 2023 3.10.3.0 Hécate January 2024 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.3.0.md 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 @@ -21,6 +21,7 @@ import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Client.Errors import Distribution.Client.Utils.Parsec (renderParseError) import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Check @@ -29,7 +30,9 @@ , runParseResult ) import Distribution.Parsec (PWarning (..), showPError) -import Distribution.Simple.Utils (defaultPackageDesc, dieWithException, notice, warn, warnError) +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 @@ -37,7 +40,6 @@ import qualified Data.Function as F import qualified Data.List as L import qualified Data.List.NonEmpty as NE -import Distribution.Client.Errors import qualified System.Directory as Dir readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) @@ -66,7 +68,7 @@ -- (e.g. @invalid-path-win@) to ignore. -> IO Bool check verbosity ignores = do - pdfile <- defaultPackageDesc verbosity + pdfile <- getSymbolicPath <$> defaultPackageDescCwd verbosity (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile -- convert parse warnings into PackageChecks let ws' = map (wrapParseWarning pdfile) ws diff --git a/src/Distribution/Client/CmdBench.hs b/src/Distribution/Client/CmdBench.hs --- a/src/Distribution/Client/CmdBench.hs +++ b/src/Distribution/Client/CmdBench.hs @@ -50,6 +50,7 @@ import Distribution.Simple.Flag ( fromFlagOrDefault ) +import Distribution.Simple.Setup (CommonSetupFlags (..)) import Distribution.Simple.Utils ( dieWithException , warn @@ -150,7 +151,7 @@ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags diff --git a/src/Distribution/Client/CmdBuild.hs b/src/Distribution/Client/CmdBuild.hs --- a/src/Distribution/Client/CmdBuild.hs +++ b/src/Distribution/Client/CmdBuild.hs @@ -40,7 +40,8 @@ , withContextAndSelectors ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , GlobalFlags , yesNoOpt ) @@ -184,7 +185,7 @@ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} module Distribution.Client.CmdClean (cleanCommand, cleanAction) where @@ -51,6 +52,10 @@ , info , wrapText ) +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import Distribution.Verbosity ( normal ) @@ -77,7 +82,7 @@ data CleanFlags = CleanFlags { cleanSaveConfig :: Flag Bool , cleanVerbosity :: Flag Verbosity - , cleanDistDir :: Flag FilePath + , cleanDistDir :: Flag (SymbolicPath Pkg (Dir Dist)) } deriving (Eq) @@ -132,7 +137,7 @@ cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do let verbosity = fromFlagOrDefault normal cleanVerbosity saveConfig = fromFlagOrDefault False cleanSaveConfig - mdistDirectory = flagToMaybe cleanDistDir + mdistDirectory = fmap getSymbolicPath $ flagToMaybe cleanDistDir mprojectDir = flagToMaybe flagProjectDir mprojectFile = flagToMaybe flagProjectFile @@ -165,7 +170,7 @@ info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive distRoot - removeEnvFiles (distProjectRootDirectory distLayout) + removeEnvFiles $ distProjectRootDirectory distLayout -- Clean specified script build caches and orphaned caches. -- There is currently no good way to specify to only clean orphaned caches. 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 @@ -22,6 +22,7 @@ ) import Distribution.Client.ProjectOrchestration import Distribution.Simple.Flag +import Distribution.Simple.Setup (CommonSetupFlags (..)) import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) @@ -123,7 +124,7 @@ then notice v "Config file not written due to flag(s)." else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig where - v = fromFlagOrDefault normal (configVerbosity configFlags) + v = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig) configureAction' flags@NixStyleFlags{..} _extraArgs globalFlags = do @@ -164,7 +165,7 @@ return (baseCtx, conf <> cliConfig) else return (baseCtx, cliConfig) where - v = fromFlagOrDefault normal (configVerbosity configFlags) + v = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags 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 @@ -54,8 +54,11 @@ , ElaboratedSharedConfig (..) ) import qualified Distribution.Client.ProjectPlanning as Planning +import Distribution.Client.ProjectPlanning.Types + ( dataDirsEnvironmentForPlan + ) import Distribution.Client.Setup - ( ConfigFlags (configVerbosity) + ( ConfigFlags (configCommonFlags) , GlobalFlags ) import Distribution.Simple.Command @@ -84,6 +87,7 @@ ( programInvocation , runProgramInvocation ) +import Distribution.Simple.Setup (CommonSetupFlags (..)) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , dieWithException @@ -166,14 +170,14 @@ -- Some dependencies may have executables. Let's put those on the PATH. let extraPaths = pathAdditions baseCtx buildCtx + pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx) + extraEnvVars = + dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + (elaboratedPlanToExecute buildCtx) programDb <- - prependProgramSearchPath - verbosity - extraPaths - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + prependProgramSearchPath verbosity extraPaths extraEnvVars pkgProgs -- Now that we have the packages, set up the environment. We accomplish this -- by creating an environment file that selects the databases and packages we @@ -222,7 +226,7 @@ then notice verbosity "Running of executable suppressed by flag(s)" else runProgramInvocation verbosity invocation where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags @@ -252,10 +256,11 @@ -> ([(String, Maybe String)] -> IO a) -> IO a withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do - createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) + let tmpDirTemplate = distTempDirectory (distDirLayout baseCtx) + createDirectoryIfMissingVerbose verbosity True tmpDirTemplate withTempDirectory verbosity - (distTempDirectory (distDirLayout baseCtx)) + tmpDirTemplate "environment." ( \tmpDir -> do envOverrides <- 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 @@ -40,7 +40,8 @@ ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (setupVerbosity) + , ConfigFlags (..) , GlobalFlags ) import Distribution.Package @@ -157,9 +158,9 @@ else do writeProjectLocalFreezeConfig distDirLayout freezeConfig notice verbosity $ - "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" + "Wrote freeze file: " ++ (distProjectFile distDirLayout "freeze") where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags diff --git a/src/Distribution/Client/CmdHaddock.hs b/src/Distribution/Client/CmdHaddock.hs --- a/src/Distribution/Client/CmdHaddock.hs +++ b/src/Distribution/Client/CmdHaddock.hs @@ -31,7 +31,8 @@ ( ElaboratedSharedConfig (..) ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , GlobalFlags , InstallFlags (..) ) @@ -147,7 +148,7 @@ flags@NixStyleFlags{..} <- mkFlagsAbsolute relFlags let - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) installDoc = fromFlagOrDefault True (installDocumentation installFlags) flags' = flags{installFlags = installFlags{installDocumentation = Flag installDoc}} cliConfig = commandLineFlagsToProjectConfig globalFlags flags' mempty -- ClientInstallFlags, not needed here 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 @@ -3,6 +3,7 @@ , haddockProjectAction ) where +import Control.Monad (mapM) import Distribution.Client.Compat.Prelude hiding (get) import Prelude () @@ -11,8 +12,8 @@ import Distribution.Client.DistDirLayout ( CabalDirLayout (..) - , DistDirLayout (..) , StoreDirLayout (..) + , distBuildDirectory ) import Distribution.Client.InstallPlan (foldPlanPackage) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -24,7 +25,6 @@ , ProjectBaseContext (..) , ProjectBuildContext (..) , TargetSelector (..) - , printPlan , pruneInstallPlanToTargets , resolveTargets , runProjectPreBuildPhase @@ -46,11 +46,20 @@ , withContextAndSelectors ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (setupVerbosity) + , ConfigFlags (..) , GlobalFlags (..) ) import Distribution.Client.TargetProblem (TargetProblem (..)) +import Distribution.Simple.BuildPaths + ( haddockBenchmarkDirPath + , haddockDirName + , haddockLibraryDirPath + , haddockLibraryPath + , haddockPath + , haddockTestDirPath + ) import Distribution.Simple.Command ( CommandUI (..) ) @@ -74,7 +83,9 @@ import Distribution.Simple.Setup ( HaddockFlags (..) , HaddockProjectFlags (..) + , HaddockTarget (..) , Visibility (..) + , defaultCommonSetupFlags , defaultHaddockFlags , haddockProjectCommand ) @@ -82,9 +93,11 @@ ( copyDirectoryRecursive , createDirectoryIfMissingVerbose , dieWithException + , info , warn ) import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..)) +import Distribution.Types.PackageDescription (PackageDescription (benchmarks, subLibraries, testSuites)) import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnitId (unUnitId) @@ -96,7 +109,7 @@ import Distribution.Client.Errors import System.Directory (doesDirectoryExist, doesFileExist) -import System.FilePath (normalise, takeDirectory, (<.>), ()) +import System.FilePath (normalise, takeDirectory, ()) haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO () haddockProjectAction flags _extraArgs globalFlags = do @@ -107,9 +120,14 @@ warn verbosity "haddock-project command is experimental, it might break in the future" -- build all packages with appropriate haddock flags - let haddockFlags = + let commonFlags = + defaultCommonSetupFlags + { setupVerbosity = haddockProjectVerbosity flags + } + haddockFlags = defaultHaddockFlags - { haddockHtml = Flag True + { haddockCommonFlags = commonFlags + , haddockHtml = Flag True , -- one can either use `--haddock-base-url` or -- `--haddock-html-location`. haddockBaseUrl = @@ -141,16 +159,19 @@ then Flag (toPathTemplate "../doc-index.html") else NoFlag , haddockKeepTempFiles = haddockProjectKeepTempFiles flags - , haddockVerbosity = haddockProjectVerbosity flags - , haddockLib = haddockProjectLib flags - , haddockOutputDir = haddockProjectOutputDir flags + , haddockResourcesDir = haddockProjectResourcesDir flags + , haddockUseUnicode = haddockProjectUseUnicode flags + -- NOTE: we don't pass `haddockOutputDir`. If we do, we'll need to + -- make sure `InstalledPackageInfo` contains the right path to + -- haddock interfaces. Instead we build documentation inside + -- `dist-newstyle` directory and copy it to the output directory. } nixFlags = (commandDefaultFlags CmdHaddock.haddockCommand) { NixStyleOptions.haddockFlags = haddockFlags , NixStyleOptions.configFlags = (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand)) - { configVerbosity = haddockProjectVerbosity flags + { configCommonFlags = commonFlags } } @@ -193,8 +214,6 @@ elaboratedPlan return (elaboratedPlan', targets) - printPlan verbosity baseCtx buildCtx - let elaboratedPlan :: ElaboratedInstallPlan elaboratedPlan = elaboratedPlanOriginal buildCtx @@ -249,61 +268,84 @@ packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> case pkg of - Left _ - | not localStyle -> - return [] - Left package -> do - -- TODO: this might not work for public packages with sublibraries. - -- Issue #9026. + 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 -> + True -> do copyDirectoryRecursive verbosity docDir destDir - >> return - ( Just - ( packageName - , interfacePath - , Hidden - ) - ) + return $ Just $ Right (packageName, interfacePath, Hidden) False -> return Nothing + Left _ -> return [] Right package -> case elabLocalToProject package of True -> do let distDirParams = elabDistDirParams sharedConfig' package - unitId = unUnitId (elabUnitId 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 + buildDir = distBuildDirectory distLayout distDirParams - packageName = unPackageName (pkgName $ elabPkgSourceId package) - let docDir = + docDir = buildDir "doc" "html" - packageName - destDir = outputDir unitId - interfacePath = - destDir - packageName - <.> "haddock" + packageDir + a <- doesDirectoryExist docDir - case a of - True -> + if a + then do copyDirectoryRecursive verbosity docDir destDir - >> return - [ - ( unitId - , interfacePath - , Visible - ) - ] - False -> do + 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 " - ++ show unitId + ++ unUnitId unitId ++ " not found in the store" ) return [] @@ -311,63 +353,60 @@ | not localStyle -> return [] False -> do - let packageName = unPackageName (pkgName $ elabPkgSourceId package) + 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 packageName - interfacePath = - destDir - packageName - <.> "haddock" + destDir = outputDir haddockDirName ForDevelopment pkg_descr + interfacePath = destDir haddockPath pkg_descr a <- doesDirectoryExist docDir case a of - True -> + True -> do copyDirectoryRecursive verbosity docDir destDir - -- non local packages will be hidden in haddock's - -- generated contents page - >> return - [ - ( unitId - , interfacePath - , Hidden - ) - ] + -- non local packages will be hidden in haddock's + -- generated contents page + return [Right (unitId, interfacePath, Hidden)] False -> do - warn - verbosity - ( "haddocks of " - ++ show unitId - ++ " not found in the store" - ) - return [] + return [Left unitId] -- -- generate index, content, etc. -- + let (missingHaddocks, packageInfos') = partitionEithers packageInfos + when (not (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 + -- `cabal` to include a version which has haddocks (or set + -- `documentation: True` in the global config). + info verbosity (intercalate "\n" missingHaddocks) + let flags' = flags { haddockProjectDir = Flag outputDir , haddockProjectInterfaces = Flag [ ( interfacePath - , Just name - , Just name + , Just url + , Just url , visibility ) - | (name, interfacePath, visibility) <- packageInfos + | (url, interfacePath, visibility) <- packageInfos' ] + , haddockProjectUseUnicode = NoFlag } createHaddockIndex verbosity (pkgConfigCompilerProgs sharedConfig') (pkgConfigCompiler sharedConfig') (pkgConfigPlatform sharedConfig') + Nothing flags' where verbosity = fromFlagOrDefault normal (haddockProjectVerbosity flags) 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 @@ -97,7 +97,8 @@ ( runRebuild ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , GlobalFlags (..) , InstallFlags (..) ) @@ -130,8 +131,9 @@ ( Compiler (..) , CompilerFlavor (..) , CompilerId (..) - , PackageDB (..) - , PackageDBStack + , PackageDBCWD + , PackageDBStackCWD + , PackageDBX (..) ) import Distribution.Simple.Configure ( configCompilerEx @@ -425,8 +427,9 @@ hcFlavor = flagToMaybe projectConfigHcFlavor hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg + extraPath = fromNubList packageConfigProgramPathExtra ++ fromNubList projectConfigProgPathExtra - configProgDb <- prependProgramSearchPath verbosity ((fromNubList packageConfigProgramPathExtra) ++ (fromNubList projectConfigProgPathExtra)) defaultProgramDb + configProgDb <- prependProgramSearchPath verbosity extraPath [] defaultProgramDb let -- ProgramDb with directly user specified paths preProgDb = @@ -539,7 +542,7 @@ traverseInstall (installCheckUnitExes InstallCheckInstall) installCfg where configFlags' = disableTestsBenchsByDefault . ignoreProgramAffixes $ configFlags - verbosity = fromFlagOrDefault normal (configVerbosity configFlags') + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags') ignoreProject = flagIgnoreProject projectFlags cliConfig = commandLineFlagsToProjectConfig @@ -956,10 +959,10 @@ -> ProjectBuildContext -> PI.PackageIndex InstalledPackageInfo -> Compiler - -> PackageDBStack + -> PackageDBStackCWD -> FilePath -- ^ Environment file - -> [GhcEnvironmentFileEntry] + -> [GhcEnvironmentFileEntry FilePath] -> Bool -- ^ Whether we need to show a warning (i.e. we created a new environment -- file, and the user did not use --package-env) @@ -1062,9 +1065,9 @@ -- | Return the package specifiers and non-global environment file entries. getEnvSpecsAndNonGlobalEntries :: PI.InstalledPackageIndex - -> [GhcEnvironmentFileEntry] + -> [GhcEnvironmentFileEntry FilePath] -> Bool - -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)]) + -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry FilePath)]) getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = if installLibs then (envSpecs, envEntries') @@ -1074,8 +1077,8 @@ environmentFileToSpecifiers :: PI.InstalledPackageIndex - -> [GhcEnvironmentFileEntry] - -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)]) + -> [GhcEnvironmentFileEntry FilePath] + -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry FilePath)]) environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId) | Just @@ -1123,8 +1126,8 @@ overwritePolicy installDir (mkSourceBinDir unit) - (mkExeName exe) (mkFinalExeName exe) + (mkExeName exe) -- | -- -- * When 'InstallCheckOnly', warn if install would fail overwrite policy @@ -1169,7 +1172,7 @@ errorMessage installdir exe = case overwritePolicy of NeverOverwrite -> "Path '" - <> (installdir prettyShow exe) + <> (installdir mkFinalExeName exe) <> "' already exists. " <> "Use --overwrite-policy=always to overwrite." -- This shouldn't even be possible, but we keep it in case symlinking or @@ -1246,7 +1249,7 @@ overwrite -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. -entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] +entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry FilePath] entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] where hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool @@ -1256,7 +1259,7 @@ go :: UnitId -> [(ComponentTarget, NonEmpty TargetSelector)] - -> [GhcEnvironmentFileEntry] + -> [GhcEnvironmentFileEntry FilePath] go unitId targets | any hasLib targets = [GhcEnvFilePackageId unitId] | otherwise = [] @@ -1288,7 +1291,7 @@ -- | Returns the list of @GhcEnvFilePackageId@ values already existing in the -- environment being operated on. The @Bool@ is @True@ if we took settings -- from an existing file, @False@ otherwise. -getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO (Bool, [GhcEnvironmentFileEntry]) +getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO (Bool, [GhcEnvironmentFileEntry FilePath]) getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do envFileExists <- doesFileExist envFile (usedExisting, allEntries) <- @@ -1332,8 +1335,8 @@ :: Compiler -> Flag FilePath -> Flag FilePath - -> [Maybe PackageDB] - -> IO PackageDBStack + -> [Maybe PackageDBCWD] + -> IO PackageDBStackCWD getPackageDbStack compiler storeDirFlag logsDirFlag packageDbs = do mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag let 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,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -37,23 +38,37 @@ regularCmd ui action = CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ()) -wrapperCmd ui verbosity' distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand +wrapperCmd + :: Monoid flags + => CommandUI flags + -> (flags -> Setup.CommonSetupFlags) + -> CommandSpec (Client.GlobalFlags -> IO ()) +wrapperCmd ui getCommonFlags = + CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand -wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) -wrapperAction command verbosityFlag distPrefFlag = +wrapperAction + :: Monoid flags + => CommandUI flags + -> (flags -> Setup.CommonSetupFlags) + -> Command (Client.GlobalFlags -> IO ()) +wrapperAction command getCommonFlags = commandAddAction command { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) + let common = getCommonFlags flags + verbosity' = Setup.fromFlagOrDefault normal (Setup.setupVerbosity common) + mbWorkDir = Setup.flagToMaybe $ Setup.setupWorkingDir common load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions{useDistPref = distPref} + distPref <- findSavedDistPref config (Setup.setupDistPref common) + let setupScriptOptions = + defaultSetupScriptOptions + { useDistPref = distPref + , useWorkingDir = mbWorkDir + } let command' = command{commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command} @@ -62,7 +77,8 @@ setupScriptOptions Nothing command' - (const flags) + getCommonFlags + (const (return flags)) (const extraArgs) -- @@ -89,25 +105,25 @@ verbosity (a, _, _, _, _, _) = verbosity a instance HasVerbosity Setup.BuildFlags where - verbosity = verbosity . Setup.buildVerbosity + verbosity = verbosity . Setup.setupVerbosity . Setup.buildCommonFlags instance HasVerbosity Setup.ConfigFlags where - verbosity = verbosity . Setup.configVerbosity + verbosity = verbosity . Setup.setupVerbosity . Setup.configCommonFlags instance HasVerbosity Setup.ReplFlags where - verbosity = verbosity . Setup.replVerbosity + verbosity = verbosity . Setup.setupVerbosity . Setup.replCommonFlags instance HasVerbosity Client.FreezeFlags where verbosity = verbosity . Client.freezeVerbosity instance HasVerbosity Setup.HaddockFlags where - verbosity = verbosity . Setup.haddockVerbosity + verbosity = verbosity . Setup.setupVerbosity . Setup.haddockCommonFlags instance HasVerbosity Client.UpdateFlags where verbosity = verbosity . Client.updateVerbosity instance HasVerbosity Setup.CleanFlags where - verbosity = verbosity . Setup.cleanVerbosity + verbosity = verbosity . Setup.setupVerbosity . Setup.cleanCommonFlags -- @@ -138,8 +154,12 @@ legacyCmd :: HasVerbosity flags => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] legacyCmd ui action = toLegacyCmd (regularCmd ui action) -legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())] -legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) +legacyWrapperCmd + :: Monoid flags + => CommandUI flags + -> (flags -> Setup.CommonSetupFlags) + -> [CommandSpec (Client.GlobalFlags -> IO ())] +legacyWrapperCmd ui commonFlags = toLegacyCmd (wrapperCmd ui commonFlags) newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] 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 @@ -49,7 +49,7 @@ import Distribution.Client.TargetProblem (TargetProblem (..)) import Distribution.Simple.BuildPaths (dllExtension, exeExtension) import Distribution.Simple.Command (CommandUI (..)) -import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault) +import Distribution.Simple.Setup (configCommonFlags, fromFlagOrDefault, setupVerbosity) import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText) import Distribution.System (Platform) import Distribution.Types.ComponentName (showComponentName) @@ -173,7 +173,7 @@ _ -> dieWithException verbosity MultipleTargetsFound where defaultVerbosity = verboseStderr silent - verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) + verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags) -- this is copied from elaboratedPackage 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 @@ -152,6 +152,7 @@ import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Utils.Path (relativeSymbolicPath) import System.Directory ( doesFileExist , getCurrentDirectory @@ -435,9 +436,8 @@ -- | Read the list of dependencies from the package description. depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] depsFromPkgDesc verbosity comp platform = do - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path + path <- tryFindPackageDesc verbosity Nothing + gpd <- readGenericPackageDescription verbosity Nothing (relativeSymbolicPath path) let cinfo = compilerInfo comp epd = finalizePD 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 @@ -103,6 +103,7 @@ ) import Distribution.Simple.Setup ( ReplOptions (..) + , setupVerbosity ) import Distribution.Simple.Utils ( TempFileOptions (..) @@ -505,7 +506,7 @@ go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) go m _ = m - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) keepTempFiles = fromFlagOrDefault False replKeepTempFiles validatedTargets ctx compiler elaboratedPlan targetSelectors = do 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 @@ -59,9 +59,11 @@ , binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan + ( ElaboratedPackageOrComponent (..) + , dataDirsEnvironmentForPlan , elabExeDependencyPaths ) + import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) , TargetContext (..) @@ -70,7 +72,8 @@ , withContextAndSelectors ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (setupVerbosity) + , ConfigFlags (..) , GlobalFlags (..) ) import Distribution.Client.TargetProblem @@ -80,6 +83,10 @@ ( giveRTSWarning , occursOnlyOrBefore ) + +import Distribution.Simple.BuildToolDepends + ( getAllInternalToolDependencies + ) import Distribution.Simple.Command ( CommandUI (..) , usageAlternatives @@ -106,9 +113,17 @@ , warn , wrapText ) + import Distribution.Types.ComponentName ( componentNameRaw ) +import Distribution.Types.Executable as PD + ( buildInfo + , exeName + ) +import qualified Distribution.Types.PackageDescription as PD + ( executables + ) import Distribution.Types.UnitId ( UnitId ) @@ -199,7 +214,7 @@ GlobalContext -> return (ctx, normal) ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta - let verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) + let verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -302,17 +317,34 @@ buildSettingDryRun (buildSettings baseCtx) || buildSettingOnlyDownload (buildSettings baseCtx) - let extraPath = - elabExeDependencyPaths pkg - ++ ( fromNubList - . projectConfigProgPathExtra - . projectConfigShared - . projectConfig - $ baseCtx - ) + let + -- HACK alert: when doing a per-package build (e.g. with a Custom setup), + -- 'elabExeDependencyPaths' will not contain any internal executables + -- (they are deliberately filtered out; and even if they weren't, they have the wrong paths). + -- We add them back in here to ensure that any "build-tool-depends" of + -- the current executable is available in PATH at runtime. + internalToolDepsOfThisExe + | ElabPackage{} <- elabPkgOrComp pkg + , let pkg_descr = elabPkgDescription pkg + , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr + , let thisExeBI = PD.buildInfo thisExe = + [ binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg depExeNm + | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI + , let depExeNm = unUnqualComponentName depExe + ] + | otherwise = + [] + extraPath = + elabExeDependencyPaths pkg + ++ ( fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx + ) + ++ internalToolDepsOfThisExe logExtraProgramSearchPath verbosity extraPath - progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) if dryRun 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -26,6 +27,7 @@ import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) , defaultNixStyleFlags + , updNixStyleCommonSetupFlags ) import Distribution.Client.ProjectConfig ( ProjectConfig @@ -47,7 +49,8 @@ , establishProjectBaseContextWithRoot ) import Distribution.Client.Setup - ( GlobalFlags (..) + ( CommonSetupFlags (..) + , GlobalFlags (..) ) import Distribution.Client.TargetSelector ( ComponentKind @@ -63,6 +66,10 @@ import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import Distribution.Client.Errors import Distribution.Client.SrcDist @@ -94,8 +101,6 @@ ) import Distribution.Simple.Setup ( Flag (..) - , configDistPref - , configVerbosity , flagToList , flagToMaybe , fromFlagOrDefault @@ -166,7 +171,7 @@ data SdistFlags = SdistFlags { sdistVerbosity :: Flag Verbosity - , sdistDistDir :: Flag FilePath + , sdistDistDir :: Flag (SymbolicPath Pkg (Dir Dist)) , sdistListSources :: Flag Bool , sdistNulSeparated :: Flag Bool , sdistOutputPath :: Flag FilePath @@ -270,7 +275,13 @@ , Just "-" <- mOutputPath' -> dieWithException verbosity Can'tWriteMultipleTarballs | otherwise -> - traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs + for_ pkgs $ \pkg -> + packageToSdist + verbosity + (distProjectRootDirectory distDirLayout) + format + (outputPath pkg) + pkg where verbosity = fromFlagOrDefault normal sdistVerbosity listSources = fromFlagOrDefault False sdistListSources @@ -281,15 +292,15 @@ prjConfig = commandLineFlagsToProjectConfig globalFlags - (defaultNixStyleFlags ()) - { configFlags = - (configFlags $ defaultNixStyleFlags ()) - { configVerbosity = sdistVerbosity - , configDistPref = sdistDistDir - } - , projectFlags = pf + (updNixStyleCommonSetupFlags (const commonFlags) $ defaultNixStyleFlags ()) + { projectFlags = pf } mempty + commonFlags = + mempty + { setupVerbosity = sdistVerbosity + , setupDistPref = sdistDistDir + } globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) @@ -341,17 +352,18 @@ TarGzArchive -> do writeLBS =<< BSL.readFile tgz _ -> dieWithException verbosity $ CannotConvertTarballPackage (show format) - Right dir -> case format of - SourceList nulSep -> do - let gpd :: GenericPackageDescription - gpd = srcpkgDescription pkg + Right dir -> do + case format of + SourceList nulSep -> do + let gpd :: GenericPackageDescription + gpd = srcpkgDescription pkg - files' <- listPackageSourcesWithDie verbosity dieWithException dir (flattenPackageDescription gpd) knownSuffixHandlers - let files = nub $ sort $ map normalise files' - let prefix = makeRelative projectRootDir dir - write $ concat [prefix i ++ [nulSep] | i <- files] - TarGzArchive -> do - packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS + files' <- listPackageSourcesWithDie verbosity dieWithException (Just $ makeSymbolicPath dir) (flattenPackageDescription gpd) knownSuffixHandlers + let files = nub $ sort $ map (normalise . getSymbolicPath) files' + let prefix = makeRelative (normalise projectRootDir) dir + write $ concat [prefix i ++ [nulSep] | i <- files] + TarGzArchive -> do + packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS -- 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 @@ -66,6 +66,7 @@ import qualified System.Exit (exitSuccess) import Distribution.Client.Errors +import Distribution.Client.Setup (CommonSetupFlags (..)) import GHC.Environment ( getFullArgs ) @@ -163,7 +164,7 @@ runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where failWhenNoTestSuites = testFailWhenNoTestSuites testFlags - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags -- | This defines what a 'TargetSelector' means for the @test@ command. 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 @@ -56,7 +56,8 @@ ) import Distribution.Client.ProjectOrchestration import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , GlobalFlags , RepoContext (..) , UpdateFlags @@ -223,7 +224,7 @@ reposToUpdate traverse_ (\_ -> collectJob jobCtrl) reposToUpdate where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) diff --git a/src/Distribution/Client/Compat/Orphans.hs b/src/Distribution/Client/Compat/Orphans.hs --- a/src/Distribution/Client/Compat/Orphans.hs +++ b/src/Distribution/Client/Compat/Orphans.hs @@ -4,8 +4,8 @@ module Distribution.Client.Compat.Orphans () where import Control.Exception (SomeException) +import Data.Typeable (typeRep) import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Typeable (typeRep) import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) import Network.URI (URI (..), URIAuth (..)) import Prelude (error, return) 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,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- @@ -177,6 +178,7 @@ ) import Distribution.Simple.Setup ( BenchmarkFlags (..) + , CommonSetupFlags (..) , ConfigFlags (..) , Flag (..) , HaddockFlags (..) @@ -204,6 +206,7 @@ , warn ) import Distribution.Solver.Types.ConstraintSource +import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath) import Distribution.Verbosity ( normal ) @@ -459,9 +462,21 @@ where combine = combine' savedClientInstallFlags + combinedSavedCommonFlags which = + CommonSetupFlags + { setupDistPref = combine setupDistPref + , setupWorkingDir = combine setupWorkingDir + , setupCabalFilePath = combine setupCabalFilePath + , setupVerbosity = combine setupVerbosity + , setupTargets = lastNonEmpty setupTargets + } + where + lastNonEmpty = lastNonEmpty' which + combine = combine' which + combinedSavedConfigureFlags = ConfigFlags - { configArgs = lastNonEmpty configArgs + { configCommonFlags = combinedSavedCommonFlags (configCommonFlags . savedConfigureFlags) , configPrograms_ = configPrograms_ . savedConfigureFlags $ b , -- TODO: NubListify configProgramPaths = lastNonEmpty configProgramPaths @@ -475,6 +490,7 @@ , configVanillaLib = combine configVanillaLib , configProfLib = combine configProfLib , configProf = combine configProf + , configProfShared = combine configProfShared , configSharedLib = combine configSharedLib , configStaticLib = combine configStaticLib , configDynExe = combine configDynExe @@ -503,9 +519,6 @@ , configDeterministic = combine configDeterministic , configIPID = combine configIPID , configCID = combine configCID - , configDistPref = combine configDistPref - , configCabalFilePath = combine configCabalFilePath - , configVerbosity = combine configVerbosity , configUserInstall = combine configUserInstall , -- TODO: NubListify configPackageDBs = lastNonEmpty configPackageDBs @@ -533,6 +546,7 @@ , configAllowDependingOnPrivateLibs = combine configAllowDependingOnPrivateLibs , configCoverageFor = combine configCoverageFor + , configIgnoreBuildTools = combine configIgnoreBuildTools } where combine = combine' savedConfigureFlags @@ -596,7 +610,8 @@ combinedSavedHaddockFlags = HaddockFlags - { -- TODO: NubListify + { haddockCommonFlags = combinedSavedCommonFlags (haddockCommonFlags . savedHaddockFlags) + , -- TODO: NubListify haddockProgramPaths = lastNonEmpty haddockProgramPaths , -- TODO: NubListify haddockProgramArgs = lastNonEmpty haddockProgramArgs @@ -614,15 +629,12 @@ , haddockQuickJump = combine haddockQuickJump , haddockHscolourCss = combine haddockHscolourCss , haddockContents = combine haddockContents - , haddockDistPref = combine haddockDistPref , haddockKeepTempFiles = combine haddockKeepTempFiles - , haddockVerbosity = combine haddockVerbosity - , haddockCabalFilePath = combine haddockCabalFilePath , haddockIndex = combine haddockIndex , haddockBaseUrl = combine haddockBaseUrl - , haddockLib = combine haddockLib + , haddockResourcesDir = combine haddockResourcesDir , haddockOutputDir = combine haddockOutputDir - , haddockArgs = lastNonEmpty haddockArgs + , haddockUseUnicode = combine haddockUseUnicode } where combine = combine' savedHaddockFlags @@ -630,8 +642,7 @@ combinedSavedTestFlags = TestFlags - { testDistPref = combine testDistPref - , testVerbosity = combine testVerbosity + { testCommonFlags = combinedSavedCommonFlags (testCommonFlags . savedTestFlags) , testHumanLog = combine testHumanLog , testMachineLog = combine testMachineLog , testShowDetails = combine testShowDetails @@ -646,12 +657,10 @@ combinedSavedBenchmarkFlags = BenchmarkFlags - { benchmarkDistPref = combine benchmarkDistPref - , benchmarkVerbosity = combine benchmarkVerbosity + { benchmarkCommonFlags = combinedSavedCommonFlags (benchmarkCommonFlags . savedBenchmarkFlags) , benchmarkOptions = lastNonEmpty benchmarkOptions } where - combine = combine' savedBenchmarkFlags lastNonEmpty = lastNonEmpty' savedBenchmarkFlags combinedSavedReplMulti = combine' savedReplMulti id @@ -686,7 +695,10 @@ mempty { configHcFlavor = toFlag defaultCompiler , configUserInstall = toFlag defaultUserInstall - , configVerbosity = toFlag normal + , configCommonFlags = + mempty + { setupVerbosity = toFlag normal + } } , savedUserInstallDirs = mempty @@ -1295,18 +1307,9 @@ [] ++ [ viewAsFieldDescr $ optionDistPref - (configDistPref . savedConfigureFlags) - ( \distPref config -> - config - { savedConfigureFlags = - (savedConfigureFlags config) - { configDistPref = distPref - } - , savedHaddockFlags = - (savedHaddockFlags config) - { haddockDistPref = distPref - } - } + (setupDistPref . configCommonFlags . savedConfigureFlags) + ( \distPref -> + updSavedCommonSetupFlags (\common -> common{setupDistPref = distPref}) ) ParseArgs ] @@ -1328,6 +1331,30 @@ toRelaxDeps True = RelaxDepsAll toRelaxDeps False = mempty +updSavedCommonSetupFlags + :: (CommonSetupFlags -> CommonSetupFlags) + -> SavedConfig + -> SavedConfig +updSavedCommonSetupFlags setFlag config = + config + { savedConfigureFlags = + let flags = savedConfigureFlags config + common = configCommonFlags flags + in flags{configCommonFlags = setFlag common} + , savedHaddockFlags = + let flags = savedHaddockFlags config + common = haddockCommonFlags flags + in flags{haddockCommonFlags = setFlag common} + , savedTestFlags = + let flags = savedTestFlags config + common = testCommonFlags flags + in flags{testCommonFlags = setFlag common} + , savedBenchmarkFlags = + let flags = savedBenchmarkFlags config + common = benchmarkCommonFlags flags + in flags{benchmarkCommonFlags = setFlag common} + } + -- TODO: next step, make the deprecated fields elicit a warning. -- deprecatedFieldDescriptions :: [FieldDescr SavedConfig] @@ -1517,6 +1544,9 @@ _ -> [s] splitMultiPath xs = xs + splitMultiSymPath = + map unsafeMakeSymbolicPath . splitMultiPath . map getSymbolicPath + -- This is a fixup, pending a full config parser rewrite, to -- ensure that config fields which can be comma-separated lists -- actually parse as comma-separated lists. @@ -1530,16 +1560,16 @@ splitMultiPath (fromNubList $ configProgramPathExtra scf) , configExtraLibDirs = - splitMultiPath + splitMultiSymPath (configExtraLibDirs scf) , configExtraLibDirsStatic = - splitMultiPath + splitMultiSymPath (configExtraLibDirsStatic scf) , configExtraFrameworkDirs = - splitMultiPath + splitMultiSymPath (configExtraFrameworkDirs scf) , configExtraIncludeDirs = - splitMultiPath + splitMultiSymPath (configExtraIncludeDirs scf) , configConfigureArgs = splitMultiPath 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- @@ -23,7 +24,6 @@ -- * Saved configure flags , readConfigFlagsFrom , readConfigFlags - , cabalConfigFlagsFile , writeConfigFlagsTo , writeConfigFlags ) where @@ -86,8 +86,8 @@ import Distribution.Simple.Compiler ( Compiler , CompilerInfo - , PackageDB (..) - , PackageDBStack + , PackageDBStackCWD + , PackageDBX (..) , compilerInfo ) import Distribution.Simple.PackageDescription @@ -99,14 +99,16 @@ ) import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , flagToMaybe , fromFlagOrDefault + , maybeToFlag , toFlag ) import Distribution.Simple.Utils as Utils ( debug - , defaultPackageDesc + , defaultPackageDescCwd , dieWithException , notice , warn @@ -121,6 +123,7 @@ ( PackageVersionConstraint (..) , thisPackageVersionConstraint ) +import Distribution.Utils.Path import Distribution.Version ( Version , VersionRange @@ -129,7 +132,6 @@ ) import Distribution.Client.Errors -import System.FilePath (()) -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags. Currently, it implements no @@ -142,7 +144,7 @@ -- | Configure the package found in the local directory configure :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> Platform @@ -200,7 +202,8 @@ (setupScriptOptions installedPkgIndex Nothing) Nothing configureCommand - (const configFlags) + configCommonFlags + (const (return configFlags)) (const extraArgs) Right installPlan0 -> let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 @@ -238,7 +241,7 @@ progdb ( fromFlagOrDefault (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags) + (setupDistPref $ configCommonFlags configFlags) ) ( chooseCabalVersion configExFlags @@ -250,11 +253,11 @@ logMsg message rest = debug verbosity message >> rest configureSetupScript - :: PackageDBStack + :: PackageDBStackCWD -> Compiler -> Platform -> ProgramDb - -> FilePath + -> SymbolicPath Pkg (Dir Dist) -> VersionRange -> Maybe Lock -> Bool @@ -305,7 +308,7 @@ -- finding the Cabal lib when compiling any Setup.hs even if we're doing -- a global install. However we also allow looking in a specific package -- db. - packageDBs' :: PackageDBStack + packageDBs' :: PackageDBStackCWD index' :: Maybe InstalledPackageIndex (packageDBs', index') = case packageDBs of @@ -387,7 +390,7 @@ -> ConfigExFlags -> InstalledPackageIndex -> SourcePackageDb - -> PkgConfigDb + -> Maybe PkgConfigDb -> IO (Progress String String SolverInstallPlan) planLocalPackage verbosity @@ -399,9 +402,9 @@ (SourcePackageDb _ packagePrefs) pkgConfigDb = do pkg <- - readGenericPackageDescription verbosity - =<< case flagToMaybe (configCabalFilePath configFlags) of - Nothing -> defaultPackageDesc verbosity + readGenericPackageDescription verbosity Nothing + =<< case flagToMaybe (setupCabalFilePath $ configCommonFlags configFlags) of + Nothing -> relativeSymbolicPath <$> defaultPackageDescCwd verbosity Just fp -> return fp let @@ -501,7 +504,8 @@ scriptOptions (Just pkg) configureCommand - configureFlags + configCommonFlags + (return . configureFlags) (const extraArgs) where gpkg :: PkgDesc.GenericPackageDescription @@ -510,7 +514,12 @@ configureFlags = filterConfigureFlags configFlags - { configIPID = + { configCommonFlags = + (configCommonFlags configFlags) + { setupVerbosity = toFlag verbosity + , setupWorkingDir = maybeToFlag $ useWorkingDir scriptOptions + } + , configIPID = if isJust (flagToMaybe (configIPID configFlags)) then -- Make sure cabal configure --ipid works. configIPID configFlags @@ -531,7 +540,6 @@ ] , -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True - , configVerbosity = toFlag verbosity , -- NB: if the user explicitly specified -- --enable-tests/--enable-benchmarks, always respect it. -- (But if they didn't, let solver decide.) @@ -570,7 +578,7 @@ readConfigFlagsFrom flags = do readCommandFlags flags configureExCommand --- | The path (relative to @--build-dir@) where the arguments to @configure@ +-- | The path (relative to the package root) where the arguments to @configure@ -- should be saved. cabalConfigFlagsFile :: FilePath -> FilePath cabalConfigFlagsFile dist = dist "cabal-config-flags" @@ -586,12 +594,12 @@ -- | Save the configure flags and environment to the specified files. writeConfigFlagsTo - :: FilePath + :: Verbosity + -> FilePath -- ^ path to saved flags file - -> Verbosity -> (ConfigFlags, ConfigExFlags) -> IO () -writeConfigFlagsTo file verb flags = do +writeConfigFlagsTo verb file flags = do writeCommandFlags verb file configureExCommand flags -- | Save the build flags to the usual location. @@ -602,4 +610,4 @@ -> (ConfigFlags, ConfigExFlags) -> IO () writeConfigFlags verb dist = - writeConfigFlagsTo (cabalConfigFlagsFile dist) verb + writeConfigFlagsTo verb (cabalConfigFlagsFile dist) 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 @@ -64,6 +64,7 @@ , addDefaultSetupDependencies , addSetupCabalMinVersionConstraint , addSetupCabalMaxVersionConstraint + , addSetupCabalProfiledDynamic ) where import Distribution.Client.Compat.Prelude @@ -631,7 +632,7 @@ } } where - isCustom = PD.buildType pkgdesc == PD.Custom + isCustom = PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc @@ -671,6 +672,22 @@ where cabalPkgname = mkPackageName "Cabal" +-- | Add an a lower bound @setup.Cabal >= 3.13@ labeled with 'ConstraintSourceProfiledDynamic' +addSetupCabalProfiledDynamic + :: DepResolverParams + -> DepResolverParams +addSetupCabalProfiledDynamic = + addConstraints + [ LabeledPackageConstraint + ( PackageConstraint + (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) + ) + ConstraintSourceProfiledDynamic + ] + where + cabalPkgname = mkPackageName "Cabal" + upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest @@ -730,7 +747,7 @@ gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc bt = PD.buildType pkgdesc - affected = bt == PD.Custom && hasBuildableFalse gpkgdesc + affected = (bt == PD.Custom || bt == PD.Hooks) && hasBuildableFalse gpkgdesc -- Does this package contain any components with non-empty 'build-depends' -- and a 'buildable' field that could potentially be set to 'False'? False @@ -764,7 +781,7 @@ resolveDependencies :: Platform -> CompilerInfo - -> PkgConfigDb + -> Maybe PkgConfigDb -> DepResolverParams -> Progress String String SolverInstallPlan resolveDependencies platform comp pkgConfigDB params = 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 @@ -43,8 +43,9 @@ import Distribution.Simple.Compiler ( Compiler (..) , OptimisationLevel (..) - , PackageDB (..) - , PackageDBStack + , PackageDBCWD + , PackageDBStackCWD + , PackageDBX (..) ) import Distribution.Simple.Configure (interpretPackageDbFlags) import Distribution.System @@ -111,7 +112,7 @@ , distSdistDirectory :: FilePath , distTempDirectory :: FilePath , distBinDirectory :: FilePath - , distPackageDB :: CompilerId -> PackageDB + , distPackageDB :: CompilerId -> PackageDBCWD , distHaddockOutputDir :: Maybe FilePath -- ^ Is needed when `--haddock-output-dir` flag is used. } @@ -121,8 +122,8 @@ { storeDirectory :: Compiler -> FilePath , storePackageDirectory :: Compiler -> UnitId -> FilePath , storePackageDBPath :: Compiler -> FilePath - , storePackageDB :: Compiler -> PackageDB - , storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack + , storePackageDB :: Compiler -> PackageDBCWD + , storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD , storeIncomingDirectory :: Compiler -> FilePath , storeIncomingLock :: Compiler -> UnitId -> FilePath } @@ -144,7 +145,7 @@ -- -- It can either be an implicit project root in the current dir if no -- @cabal.project@ file is found, or an explicit root if either --- the file is found or the project root directory was specicied. +-- the file is found or the project root directory was specified. data ProjectRoot = -- | An implicit project root. It contains the absolute project -- root dir. @@ -167,8 +168,7 @@ :: ProjectRoot -- ^ the project root -> Maybe FilePath - -- ^ the @dist@ directory or default - -- (absolute or relative to the root) + -- ^ the @dist@ directory (relative to package root) -> Maybe FilePath -- ^ the documentation directory -> DistDirLayout @@ -259,7 +259,7 @@ distPackageDBPath :: CompilerId -> FilePath distPackageDBPath compid = distDirectory "packagedb" prettyShow compid - distPackageDB :: CompilerId -> PackageDB + distPackageDB :: CompilerId -> PackageDBCWD distPackageDB = SpecificPackageDB . distPackageDBPath distHaddockOutputDir :: Maybe FilePath @@ -283,11 +283,11 @@ storePackageDBPath compiler = storeDirectory compiler "package.db" - storePackageDB :: Compiler -> PackageDB + storePackageDB :: Compiler -> PackageDBCWD storePackageDB compiler = SpecificPackageDB (storePackageDBPath compiler) - storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack + storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD storePackageDBStack compiler extraPackageDB = (interpretPackageDbFlags False extraPackageDB) ++ [storePackageDB compiler] 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 @@ -44,10 +44,6 @@ ( packageId ) import Distribution.Simple.Compiler - ( Compiler - , PackageDBStack - , compilerInfo - ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program ( ProgramDb @@ -88,7 +84,7 @@ -- | Fetch a list of packages and their dependencies. fetch :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> Platform @@ -161,7 +157,7 @@ -> FetchFlags -> InstalledPackageIndex -> SourcePackageDb - -> PkgConfigDb + -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage] planPackages 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 @@ -11,22 +11,7 @@ -- input values they depend on have changed. module Distribution.Client.FileMonitor ( -- * Declaring files to monitor - MonitorFilePath (..) - , MonitorKindFile (..) - , MonitorKindDir (..) - , RootedGlob (..) - , monitorFile - , monitorFileHashed - , monitorNonExistentFile - , monitorFileExistence - , monitorDirectory - , monitorNonExistentDirectory - , monitorDirectoryExistence - , monitorFileOrDirectory - , monitorFileGlob - , monitorFileGlobExistence - , monitorFileSearchPath - , monitorFileHashedSearchPath + module Distribution.Simple.FileMonitor.Types -- * Creating and checking sets of monitored files , FileMonitor (..) @@ -50,7 +35,6 @@ import Data.Binary.Get (runGetOrFail) import qualified Data.ByteString.Lazy as BS -import qualified Data.Hashable as Hashable import qualified Data.Map.Strict as Map import Control.Exception @@ -66,133 +50,18 @@ import Control.Monad.Trans (MonadIO, liftIO) import Distribution.Client.Glob +import Distribution.Client.HashValue import Distribution.Client.Utils (MergeResult (..), mergeBy) import Distribution.Compat.Time +import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Utils.Structured (Tag (..), structuredEncode) + import System.Directory import System.FilePath import System.IO ------------------------------------------------------------------------------ --- Types for specifying files to monitor --- - --- | A description of a file (or set of files) to monitor for changes. --- --- Where file paths are relative they are relative to a common directory --- (e.g. project root), not necessarily the process current directory. -data MonitorFilePath - = MonitorFile - { monitorKindFile :: !MonitorKindFile - , monitorKindDir :: !MonitorKindDir - , monitorPath :: !FilePath - } - | MonitorFileGlob - { monitorKindFile :: !MonitorKindFile - , monitorKindDir :: !MonitorKindDir - , monitorPathGlob :: !RootedGlob - } - deriving (Eq, Show, Generic) - -data MonitorKindFile - = FileExists - | FileModTime - | FileHashed - | FileNotExists - deriving (Eq, Show, Generic) - -data MonitorKindDir - = DirExists - | DirModTime - | DirNotExists - deriving (Eq, Show, Generic) - -instance Binary MonitorFilePath -instance Binary MonitorKindFile -instance Binary MonitorKindDir - -instance Structured MonitorFilePath -instance Structured MonitorKindFile -instance Structured MonitorKindDir - --- | Monitor a single file for changes, based on its modification time. --- The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. -monitorFile :: FilePath -> MonitorFilePath -monitorFile = MonitorFile FileModTime DirNotExists - --- | Monitor a single file for changes, based on its modification time --- and content hash. The monitored file is considered to have changed if --- it no longer exists or if its modification time and content hash have --- changed. -monitorFileHashed :: FilePath -> MonitorFilePath -monitorFileHashed = MonitorFile FileHashed DirNotExists - --- | Monitor a single non-existent file for changes. The monitored file --- is considered to have changed if it exists. -monitorNonExistentFile :: FilePath -> MonitorFilePath -monitorNonExistentFile = MonitorFile FileNotExists DirNotExists - --- | Monitor a single file for existence only. The monitored file is --- considered to have changed if it no longer exists. -monitorFileExistence :: FilePath -> MonitorFilePath -monitorFileExistence = MonitorFile FileExists DirNotExists - --- | Monitor a single directory for changes, based on its modification --- time. The monitored directory is considered to have changed if it no --- longer exists or if its modification time has changed. -monitorDirectory :: FilePath -> MonitorFilePath -monitorDirectory = MonitorFile FileNotExists DirModTime - --- | Monitor a single non-existent directory for changes. The monitored --- directory is considered to have changed if it exists. -monitorNonExistentDirectory :: FilePath -> MonitorFilePath --- Just an alias for monitorNonExistentFile, since you can't --- tell the difference between a non-existent directory and --- a non-existent file :) -monitorNonExistentDirectory = monitorNonExistentFile - --- | Monitor a single directory for existence. The monitored directory is --- considered to have changed only if it no longer exists. -monitorDirectoryExistence :: FilePath -> MonitorFilePath -monitorDirectoryExistence = MonitorFile FileNotExists DirExists - --- | Monitor a single file or directory for changes, based on its modification --- time. The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. -monitorFileOrDirectory :: FilePath -> MonitorFilePath -monitorFileOrDirectory = MonitorFile FileModTime DirModTime - --- | Monitor a set of files (or directories) identified by a file glob. --- The monitored glob is considered to have changed if the set of files --- matching the glob changes (i.e. creations or deletions), or for files if the --- modification time and content hash of any matching file has changed. -monitorFileGlob :: RootedGlob -> MonitorFilePath -monitorFileGlob = MonitorFileGlob FileHashed DirExists - --- | Monitor a set of files (or directories) identified by a file glob for --- existence only. The monitored glob is considered to have changed if the set --- of files matching the glob changes (i.e. creations or deletions). -monitorFileGlobExistence :: RootedGlob -> MonitorFilePath -monitorFileGlobExistence = MonitorFileGlob FileExists DirExists - --- | Creates a list of files to monitor when you search for a file which --- unsuccessfully looked in @notFoundAtPaths@ before finding it at --- @foundAtPath@. -monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileSearchPath notFoundAtPaths foundAtPath = - monitorFile foundAtPath - : map monitorNonExistentFile notFoundAtPaths - --- | Similar to 'monitorFileSearchPath', but also instructs us to --- monitor the hash of the found file. -monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileHashedSearchPath notFoundAtPaths foundAtPath = - monitorFileHashed foundAtPath - : map monitorNonExistentFile notFoundAtPaths - ------------------------------------------------------------------------------- -- Implementation types, files status -- @@ -214,8 +83,6 @@ instance Binary MonitorStateFileSet instance Structured MonitorStateFileSet -type Hash = Int - -- | The state necessary to determine whether a monitored file has changed. -- -- This covers all the cases of 'MonitorFilePath' except for globs which is @@ -238,7 +105,7 @@ | -- | cached file mtime MonitorStateFileModTime !ModTime | -- | cached mtime and content hash - MonitorStateFileHashed !ModTime !Hash + MonitorStateFileHashed !ModTime !HashValue | MonitorStateDirExists | -- | cached dir mtime MonitorStateDirModTime !ModTime @@ -1092,21 +959,21 @@ -- updating a file monitor the set of files is the same or largely the same so -- we can grab the previously known content hashes with their corresponding -- mtimes. -type FileHashCache = Map FilePath (ModTime, Hash) +type FileHashCache = Map FilePath (ModTime, HashValue) -- | We declare it a cache hit if the mtime of a file is the same as before. -lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash +lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe HashValue lookupFileHashCache hashcache file mtime = do (mtime', hash) <- Map.lookup file hashcache guard (mtime' == mtime) return hash -- | Either get it from the cache or go read the file -getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash +getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO HashValue getFileHash hashcache relfile absfile mtime = case lookupFileHashCache hashcache relfile mtime of Just hash -> return hash - Nothing -> readFileHash absfile + Nothing -> readFileHashValue absfile -- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While -- in principle we could preserve the structure of the previous state, given @@ -1129,7 +996,7 @@ collectAllFileHashes singlePaths `Map.union` collectAllGlobHashes globPaths - collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash) + collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, HashValue) collectAllFileHashes singlePaths = Map.fromList [ (fpath, (mtime, hash)) @@ -1141,7 +1008,7 @@ singlePaths ] - collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash) + collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, HashValue) collectAllGlobHashes globPaths = Map.fromList [ (fpath, (mtime, hash)) @@ -1149,7 +1016,7 @@ , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] - collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Hash))] + collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))] collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = [ res | (subdir, fstate) <- entries @@ -1174,13 +1041,13 @@ unless unchanged (somethingChanged file) -- | Within the @root@ directory, check if @file@ has its 'ModTime' and --- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is +-- 'HashValue' is the same as @mtime@ and @hash@, short-circuiting if it is -- different. probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime - -> Hash + -> HashValue -> ChangedM () probeFileModificationTimeAndHash root file mtime hash = do unchanged <- @@ -1223,12 +1090,12 @@ return (mtime == mtime') -- | Returns @True@ if, inside the @root@ directory, @file@ has the --- same 'ModTime' and 'Hash' as @mtime and @chash@. +-- same 'ModTime' and 'HashValue' as @mtime and @chash@. checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath -> ModTime - -> Hash + -> HashValue -> IO Bool checkFileModificationTimeAndHashUnchanged root file mtime chash = handleIOException False $ do @@ -1236,15 +1103,9 @@ if mtime == mtime' then return True else do - chash' <- readFileHash (root file) + chash' <- readFileHashValue (root file) return (chash == chash') --- | Read a non-cryptographic hash of a @file@. -readFileHash :: FilePath -> IO Hash -readFileHash file = - withBinaryFile file ReadMode $ \hnd -> - evaluate . Hashable.hash =<< BS.hGetContents hnd - -- | Given a directory @dir@, return @Nothing@ if its 'ModTime' -- is the same as @mtime@, and the new 'ModTime' if it is not. checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) @@ -1258,12 +1119,9 @@ -- | Run an IO computation, returning the first argument @e@ if there is an 'error' -- call. ('ErrorCall') handleErrorCall :: a -> IO a -> IO a -handleErrorCall e = handle handler where -#if MIN_VERSION_base(4,9,0) +handleErrorCall e = handle handler + where handler (ErrorCallWithLocation _ _) = return e -#else - handler (ErrorCall _) = return e -#endif -- | Run an IO computation, returning @e@ if there is any 'IOException'. -- 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 @@ -61,10 +61,6 @@ , packageVersion ) import Distribution.Simple.Compiler - ( Compiler - , PackageDBStack - , compilerInfo - ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program ( ProgramDb @@ -98,7 +94,7 @@ -- constraining each dependency to an exact version. freeze :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> Platform @@ -146,7 +142,7 @@ -- command. getFreezePkgs :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> Platform @@ -199,7 +195,7 @@ -> FreezeFlags -> InstalledPackageIndex -> SourcePackageDb - -> PkgConfigDb + -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> IO [SolverPlanPackage] planPackages diff --git a/src/Distribution/Client/GenBounds.hs b/src/Distribution/Client/GenBounds.hs --- a/src/Distribution/Client/GenBounds.hs +++ b/src/Distribution/Client/GenBounds.hs @@ -46,10 +46,6 @@ ( finalizePD ) import Distribution.Simple.Compiler - ( Compiler - , PackageDBStack - , compilerInfo - ) import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) @@ -67,6 +63,7 @@ ( defaultComponentRequestedSpec ) import Distribution.Types.Dependency +import Distribution.Utils.Path (relativeSymbolicPath) import Distribution.Version ( LowerBound (..) , UpperBound (..) @@ -80,9 +77,6 @@ , intersectVersionRanges , orLaterVersion ) -import System.Directory - ( getCurrentDirectory - ) -- | Given a version, return an API-compatible (according to PVP) version range. -- @@ -121,7 +115,7 @@ -- | Entry point for the @gen-bounds@ command. genBounds :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> Platform @@ -132,9 +126,8 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do let cinfo = compilerInfo comp - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path + path <- relativeSymbolicPath <$> tryFindPackageDesc verbosity Nothing + gpd <- readGenericPackageDescription verbosity Nothing path -- NB: We don't enable tests or benchmarks, since often they -- don't really have useful bounds. let epd = diff --git a/src/Distribution/Client/Glob.hs b/src/Distribution/Client/Glob.hs --- a/src/Distribution/Client/Glob.hs +++ b/src/Distribution/Client/Glob.hs @@ -12,48 +12,25 @@ , Glob (..) , GlobPiece (..) , GlobPieces - , matchGlob - , matchGlobPieces , matchFileGlob ) where import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Glob import Distribution.Simple.Glob.Internal + ( Glob (..) + , GlobPiece (..) + , GlobPieces + ) import System.Directory import System.FilePath -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- | A file path specified by globbing, relative --- to some root directory. -data RootedGlob - = RootedGlob - FilePathRoot - -- ^ what the glob is relative to - Glob - -- ^ the glob - deriving (Eq, Show, Generic) - -instance Binary RootedGlob -instance Structured RootedGlob - -data FilePathRoot - = FilePathRelative - | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' - FilePathRoot FilePath - | FilePathHomeDir - deriving (Eq, Show, Generic) - -instance Binary FilePathRoot -instance Structured FilePathRoot - -- | Check if a 'RootedGlob' doesn't actually make use of any globbing and -- is in fact equivalent to a non-glob 'FilePath'. -- @@ -105,33 +82,3 @@ case globroot of FilePathRelative -> return matches _ -> return (map (root ) matches) - ------------------------------------------------------------------------------- --- Parsing & pretty-printing --- - -instance Pretty RootedGlob where - pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob - -instance Parsec RootedGlob where - parsec = do - root <- parsec - case root of - FilePathRelative -> RootedGlob root <$> parsec - _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing) - -instance Pretty FilePathRoot where - pretty FilePathRelative = Disp.empty - pretty (FilePathRoot root) = Disp.text root - pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' - -instance Parsec FilePathRoot where - parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative - where - root = FilePathRoot "/" <$ P.char '/' - home = FilePathHomeDir <$ P.string "~/" - drive = do - dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') - _ <- P.char ':' - _ <- P.char '/' <|> P.char '\\' - return (FilePathRoot (toUpper dr : ":\\")) 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 @@ -192,7 +192,7 @@ -- Only use the external http transports if we actually have to -- (or have been told to do so) let transport' - | uriScheme uri == "http:" + | isHttpURI uri , not (transportManuallySelected transport) = plainHttpTransport | otherwise = @@ -251,20 +251,35 @@ -- Utilities for repo url management -- +-- | If the remote repo is accessed over HTTPS, ensure that the transport +-- supports HTTPS. remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () -remoteRepoCheckHttps verbosity transport repo - | uriScheme (remoteRepoURI repo) == "https:" - , not (transportSupportsHttps transport) = - dieWithException verbosity $ RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage - | otherwise = return () +remoteRepoCheckHttps verbosity transport repo = + transportCheckHttpsWithError verbosity transport (remoteRepoURI repo) $ + RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage +-- | If the URI scheme is HTTPS, ensure the transport supports HTTPS. transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () -transportCheckHttps verbosity transport uri - | uriScheme uri == "https:" +transportCheckHttps verbosity transport uri = + transportCheckHttpsWithError verbosity transport uri $ + TransportCheckHttps uri requiresHttpsErrorMessage + +-- | If the URI scheme is HTTPS, ensure the transport supports HTTPS. +-- If not, fail with the given error. +transportCheckHttpsWithError + :: Verbosity -> HttpTransport -> URI -> CabalInstallException -> IO () +transportCheckHttpsWithError verbosity transport uri err + | isHttpsURI uri , not (transportSupportsHttps transport) = - dieWithException verbosity $ TransportCheckHttps uri requiresHttpsErrorMessage + dieWithException verbosity err | otherwise = return () +isHttpsURI :: URI -> Bool +isHttpsURI uri = uriScheme uri == "https:" + +isHttpURI :: URI -> Bool +isHttpURI uri = uriScheme uri == "http:" + requiresHttpsErrorMessage :: String requiresHttpsErrorMessage = "requires HTTPS however the built-in HTTP implementation " @@ -280,12 +295,12 @@ remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo remoteRepoTryUpgradeToHttps verbosity transport repo | remoteRepoShouldTryHttps repo - , uriScheme (remoteRepoURI repo) == "http:" + , isHttpURI (remoteRepoURI repo) , not (transportSupportsHttps transport) , not (transportManuallySelected transport) = dieWithException verbosity $ TryUpgradeToHttps [name | (name, _, True, _) <- supportedTransports] | remoteRepoShouldTryHttps repo - , uriScheme (remoteRepoURI repo) == "http:" + , isHttpURI (remoteRepoURI repo) , transportSupportsHttps transport = return repo @@ -408,7 +423,7 @@ case find (\(name', _, _, _) -> name' == name) supportedTransports of Just (_, mprog, _tls, mkTrans) -> do - baseProgDb <- prependProgramSearchPath verbosity extraPath emptyProgramDb + baseProgDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb progdb <- case mprog of Nothing -> return emptyProgramDb Just prog -> snd <$> requireProgram verbosity prog baseProgDb @@ -424,7 +439,7 @@ -- for all the transports except plain-http we need to try and find -- their external executable - baseProgDb <- prependProgramSearchPath verbosity extraPath emptyProgramDb + baseProgDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb progdb <- configureAllKnownPrograms verbosity $ addKnownPrograms @@ -505,12 +520,18 @@ (Just (Left (uname, passwd)), _) -> Just $ Left (uname ++ ":" ++ passwd) (Nothing, Just a) -> Just $ Left a (Nothing, Nothing) -> Nothing + let authnSchemeArg + -- When using TLS, we can accept Basic authentication. Let curl + -- decide based on the scheme(s) offered by the server. + | isHttpsURI uri = "--anyauth" + -- When not using TLS, force Digest scheme + | otherwise = "--digest" case mbAuthStringToken of Just (Left up) -> progInvocation { progInvokeInput = Just . IODataText . unlines $ - [ "--digest" + [ authnSchemeArg , "--user " ++ up ] , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation 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,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -82,9 +83,6 @@ , emptyPackageDescription ) import Distribution.Simple.Compiler - ( Compiler - , PackageDBStack - ) import qualified Distribution.Simple.Configure as Configure ( getInstalledPackages , getInstalledPackagesMonitorFiles @@ -114,7 +112,6 @@ , parseGenericPackageDescriptionMaybe ) import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse -import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex @@ -134,7 +131,7 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath - , tryFindAddSourcePackageDesc + , tryReadAddSourcePackageDesc ) import Distribution.Compat.Directory (listDirectory) import Distribution.Compat.Time (getFileAge, getModTime) @@ -150,7 +147,7 @@ , (<.>) , () ) -import qualified System.FilePath.Posix as FilePath.Posix +import qualified System.FilePath as FilePath import System.IO import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafeInterleaveIO) @@ -163,11 +160,11 @@ getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack + -> PackageDBStackCWD -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDbs progdb = - Configure.getInstalledPackages verbosity' comp packageDbs progdb + Configure.getInstalledPackages verbosity' comp Nothing (coercePackageDBStack packageDbs) progdb where verbosity' = lessVerbose verbosity @@ -460,8 +457,8 @@ if isDoesNotExistError e then do case repo of - RepoRemote{..} -> dieWithException verbosity $ MissingPackageList repoRemote - RepoSecure{..} -> dieWithException verbosity $ MissingPackageList repoRemote + RepoRemote{..} -> warn verbosity $ exceptionMessageCabalInstall $ MissingPackageList repoRemote + RepoSecure{..} -> warn verbosity $ exceptionMessageCabalInstall $ MissingPackageList repoRemote RepoLocalNoIndex local _ -> warn verbosity $ "Error during construction of local+noindex " @@ -638,8 +635,7 @@ if not dirExists then return Nothing else do - cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." - descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile + descr <- tryReadAddSourcePackageDesc verbosity path "Error reading package index." return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) @@ -930,7 +926,7 @@ let bs = BS.toStrict contents in ((`CacheGPD` bs) <$> parseGenericPackageDescriptionMaybe bs) where - filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" + filename = prettyShow pkgId FilePath. prettyShow (packageName pkgId) ++ ".cabal" readCabalEntry _ _ x = x withIndexEntries verbosity index callback _ = do -- non-secure repositories @@ -1044,8 +1040,7 @@ path <- fmap byteStringToFilePath . getEntryContent $ blockno pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc verbosity path err - PackageDesc.Parse.readGenericPackageDescription normal file + tryReadAddSourcePackageDesc verbosity path err let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) accum srcpkgs (srcpkg : btrs) prefs entries accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = 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 @@ -31,7 +31,7 @@ -- | This is the main driver for the init script. initCmd :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> ProgramDb @@ -41,8 +41,7 @@ installedPkgIndex <- getInstalledPackages v comp packageDBs progdb sourcePkgDb <- getSourcePackages v repoCtxt hSetBuffering stdout NoBuffering - settings <- createProject v installedPkgIndex sourcePkgDb initFlags - writeProject settings + runPromptIO (writeProject =<< createProject v installedPkgIndex sourcePkgDb initFlags) where -- When no flag is set, default to interactive. -- 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 @@ -135,6 +135,7 @@ , CabalSpecV2_4 , CabalSpecV3_0 , CabalSpecV3_4 + , CabalSpecV3_14 ] defaultInitFlags :: InitFlags 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 @@ -180,7 +180,7 @@ , field "hs-source-dirs" formatHsSourceDirs - (unsafeMakeSymbolicPath <$> srcDirs) + (makeSymbolicPath <$> srcDirs) ["Directories containing source files."] True opts @@ -247,7 +247,7 @@ , field "hs-source-dirs" formatHsSourceDirs - (unsafeMakeSymbolicPath <$> appDirs) + (makeSymbolicPath <$> appDirs) ["Directories containing source files."] True opts @@ -316,7 +316,7 @@ , field "hs-source-dirs" formatHsSourceDirs - (unsafeMakeSymbolicPath <$> dirs) + (makeSymbolicPath <$> dirs) ["Directories containing source files."] True opts @@ -473,14 +473,14 @@ Just fs -> field "extra-doc-files" - formatExtraSourceFiles + (formatExtraSourceFiles . map unsafeMakeSymbolicPath) (toList fs) ["Extra doc files to be distributed with the package, such as a CHANGELOG or a README."] True opts , field "extra-source-files" - formatExtraSourceFiles + (formatExtraSourceFiles . map unsafeMakeSymbolicPath) (toList $ _pkgExtraSrcFiles pkgDesc) ["Extra source files to be distributed with the package, such as examples, or a tutorial module."] True 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 @@ -313,6 +313,7 @@ parseCabalVersion "3.0" = CabalSpecV3_0 parseCabalVersion "3.4" = CabalSpecV3_4 parseCabalVersion "3.12" = CabalSpecV3_12 + parseCabalVersion "3.14" = CabalSpecV3_14 parseCabalVersion _ = defaultCabalVersion -- 2.4 displayCabalVersion :: CabalSpecVersion -> String displayCabalVersion v = case v of @@ -321,6 +322,7 @@ CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" CabalSpecV3_4 -> "3.4 (+ sublibraries in 'mixins', optional 'default-language')" + CabalSpecV3_14 -> "3.14 (+ build-type: Hooks)" _ -> showCabalSpecVersion v packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName @@ -458,13 +460,17 @@ ghc2021 = "GHC2021 (requires at least GHC 9.2)" ghc2024 = "GHC2024 (requires at least GHC 9.10)" + lastChosenLanguage <- getLastChosenLanguage + l <- promptList ("Choose a language for your " ++ pkgType) [h2010, h98, ghc2021, ghc2024] - (DefaultPrompt h2010) + (DefaultPrompt (maybe h2010 id lastChosenLanguage)) Nothing True + + setLastChosenLanguage (Just l) if | l == h2010 -> return Haskell2010 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 @@ -165,14 +165,14 @@ guessGitInfo :: Interactive m => String -> m (Maybe String) guessGitInfo target = do - localInfo <- readProcessWithExitCode "git" ["config", "--local", target] "" - if null $ snd' localInfo - then do - globalInfo <- readProcessWithExitCode "git" ["config", "--global", target] "" - case fst' globalInfo of - ExitSuccess -> return $ Just (trim $ snd' globalInfo) - _ -> return Nothing - else return $ Just (trim $ snd' localInfo) - where - fst' (x, _, _) = x - snd' (_, x, _) = x + localInfo <- maybeReadProcessWithExitCode "git" ["config", "--local", target] "" + case localInfo of + Nothing -> return Nothing + Just (_, localStdout, _) -> + if null localStdout + then do + globalInfo <- maybeReadProcessWithExitCode "git" ["config", "--global", target] "" + case globalInfo of + Just (ExitSuccess, globalStdout, _) -> return $ Just (trim globalStdout) + _ -> return Nothing + else return $ Just (trim localStdout) 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 @@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Distribution.Client.Init.Types @@ -39,7 +41,11 @@ -- * Typeclasses , Interactive (..) , BreakException (..) - , PurePrompt (..) + , PromptIO + , runPromptIO + , Inputs + , PurePrompt + , runPrompt , evalPrompt , Severity (..) @@ -63,9 +69,12 @@ import Prelude (read) import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Reader import Data.List.NonEmpty (fromList) +import qualified Data.IORef import Distribution.CabalSpecVersion import Distribution.Client.Utils as P import Distribution.Fields.Pretty @@ -282,15 +291,33 @@ -- -------------------------------------------------------------------- -- -- Interactive prompt monad +newtype PromptIO a = PromptIO (ReaderT (Data.IORef.IORef SessionState) IO a) + deriving (Functor, Applicative, Monad, MonadIO) + +sessionState :: PromptIO (Data.IORef.IORef SessionState) +sessionState = PromptIO ask + +runPromptIO :: PromptIO a -> IO a +runPromptIO (PromptIO pio) = + (Data.IORef.newIORef newSessionState) >>= (runReaderT pio) + +type Inputs = NonEmpty String + newtype PurePrompt a = PurePrompt - { _runPrompt - :: NonEmpty String - -> Either BreakException (a, NonEmpty String) + { runPromptState + :: (Inputs, SessionState) + -> Either BreakException (a, (Inputs, SessionState)) } deriving (Functor) -evalPrompt :: PurePrompt a -> NonEmpty String -> a -evalPrompt act s = case _runPrompt act s of +runPrompt :: PurePrompt a -> Inputs -> Either BreakException (a, Inputs) +runPrompt act args = + fmap + (\(a, (s, _)) -> (a, s)) + (runPromptState act (args, newSessionState)) + +evalPrompt :: PurePrompt a -> Inputs -> a +evalPrompt act s = case runPrompt act s of Left e -> error $ show e Right (a, _) -> a @@ -306,7 +333,7 @@ return = pure PurePrompt a >>= k = PurePrompt $ \s -> case a s of Left e -> Left e - Right (a', s') -> _runPrompt (k a') s' + Right (a', s') -> runPromptState (k a') s' class Monad m => Interactive m where -- input functions @@ -320,6 +347,7 @@ doesFileExist :: FilePath -> m Bool canonicalizePathNoThrow :: FilePath -> m FilePath readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String) + maybeReadProcessWithExitCode :: FilePath -> [String] -> String -> m (Maybe (ExitCode, String, String)) getEnvironment :: m [(String, String)] getCurrentYear :: m Integer listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath] @@ -341,37 +369,63 @@ break :: m Bool throwPrompt :: BreakException -> m a -instance Interactive IO where - getLine = P.getLine - readFile = P.readFile - getCurrentDirectory = P.getCurrentDirectory - getHomeDirectory = P.getHomeDirectory - getDirectoryContents = P.getDirectoryContents - listDirectory = P.listDirectory - doesDirectoryExist = P.doesDirectoryExist - doesFileExist = P.doesFileExist - canonicalizePathNoThrow = P.canonicalizePathNoThrow - readProcessWithExitCode = Process.readProcessWithExitCode - getEnvironment = P.getEnvironment - getCurrentYear = P.getCurrentYear - listFilesInside = P.listFilesInside - listFilesRecursive = P.listFilesRecursive + -- session state functions + getLastChosenLanguage :: m (Maybe String) + setLastChosenLanguage :: (Maybe String) -> m () - putStr = P.putStr - putStrLn = P.putStrLn - createDirectory = P.createDirectory - removeDirectory = P.removeDirectoryRecursive - writeFile = P.writeFile - removeExistingFile = P.removeExistingFile - copyFile = P.copyFile - renameDirectory = P.renameDirectory - hFlush = System.IO.hFlush +newtype SessionState = SessionState + { lastChosenLanguage :: (Maybe String) + } + +newSessionState :: SessionState +newSessionState = SessionState{lastChosenLanguage = Nothing} + +instance Interactive PromptIO where + getLine = liftIO P.getLine + 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 + canonicalizePathNoThrow = liftIO <$> P.canonicalizePathNoThrow + readProcessWithExitCode a b c = liftIO $ Process.readProcessWithExitCode a b c + maybeReadProcessWithExitCode a b c = liftIO $ (Just <$> Process.readProcessWithExitCode a b c) `P.catch` const @_ @IOError (pure Nothing) + getEnvironment = liftIO P.getEnvironment + getCurrentYear = liftIO P.getCurrentYear + listFilesInside test dir = do + -- test is run within a new env and not the current env + -- all usages of listFilesInside are pure functions actually + liftIO $ P.listFilesInside (\f -> liftIO $ runPromptIO (test f)) dir + listFilesRecursive = liftIO <$> P.listFilesRecursive + + putStr = liftIO <$> P.putStr + putStrLn = liftIO <$> P.putStrLn + createDirectory = liftIO <$> P.createDirectory + removeDirectory = liftIO <$> P.removeDirectoryRecursive + writeFile a b = liftIO $ P.writeFile a b + removeExistingFile = liftIO <$> P.removeExistingFile + 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 () | otherwise = putStrLn $ "[" ++ displaySeverity severity ++ "] " ++ msg break = return False - throwPrompt = throwM + throwPrompt = liftIO <$> throwM + getLastChosenLanguage = do + stateRef <- sessionState + liftIO $ lastChosenLanguage <$> Data.IORef.readIORef stateRef + + setLastChosenLanguage value = do + stateRef <- sessionState + liftIO $ + Data.IORef.modifyIORef + stateRef + (\state -> state{lastChosenLanguage = value}) + instance Interactive PurePrompt where getLine = pop readFile !_ = pop @@ -387,6 +441,7 @@ readProcessWithExitCode !_ !_ !_ = do input <- pop return (ExitSuccess, input, "") + maybeReadProcessWithExitCode a b c = Just <$> readProcessWithExitCode a b c getEnvironment = fmap (map read) popList getCurrentYear = fmap read pop listFilesInside pred' !_ = do @@ -411,13 +466,18 @@ _ -> return () break = return True - throwPrompt (BreakException e) = PurePrompt $ \s -> + throwPrompt (BreakException e) = PurePrompt $ \(i, _) -> Left $ BreakException - ("Error: " ++ e ++ "\nStacktrace: " ++ show s) + ("Error: " ++ e ++ "\nStacktrace: " ++ show i) + getLastChosenLanguage = PurePrompt $ \(i, s) -> + Right (lastChosenLanguage s, (i, s)) + setLastChosenLanguage l = PurePrompt $ \(i, s) -> + Right ((), (i, s{lastChosenLanguage = l})) + pop :: PurePrompt String -pop = PurePrompt $ \(p :| ps) -> Right (p, fromList ps) +pop = PurePrompt $ \(i :| is, s) -> Right (i, (fromList is, s)) popAbsolute :: PurePrompt String popAbsolute = do @@ -429,7 +489,7 @@ pop >>= \case "True" -> pure True "False" -> pure False - s -> throwPrompt $ BreakException $ "popBool: " ++ s + i -> throwPrompt $ BreakException $ "popBool: " ++ i popList :: PurePrompt [String] popList = 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 @@ -128,7 +128,7 @@ Nothing -> return Nothing Just moduleName -> do let fileExtension = takeExtension f - relativeSourcePath <- makeRelative f <$> getCurrentDirectory + relativeSourcePath <- makeRelative (normalise f) <$> getCurrentDirectory imports <- retrieveModuleImports f extensions <- retrieveModuleExtensions f 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- @@ -56,7 +57,6 @@ ( equalFilePath , takeDirectory , (<.>) - , () ) import System.IO ( IOMode (AppendMode) @@ -111,6 +111,7 @@ , InstallFlags (..) , RepoContext (..) , configureCommand + , filterCommonFlags , filterConfigureFlags , filterTestFlags ) @@ -172,8 +173,9 @@ ( Compiler (compilerId) , CompilerId (..) , CompilerInfo (..) - , PackageDB (..) - , PackageDBStack + , PackageDBCWD + , PackageDBStackCWD + , PackageDBX (..) , compilerFlavor , compilerInfo ) @@ -193,30 +195,35 @@ import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Register (defaultRegisterOptions, registerPackage) import Distribution.Simple.Setup - ( BenchmarkFlags + ( BenchmarkFlags (..) , BuildFlags (..) + , CommonSetupFlags (..) + , CopyFlags (..) , HaddockFlags (..) - , TestFlags + , RegisterFlags (..) + , TestFlags (..) , buildCommand + , copyCommonFlags + , defaultCommonSetupFlags , defaultDistPref , emptyBuildFlags , flagToMaybe , fromFlag , fromFlagOrDefault , haddockCommand + , maybeToFlag + , registerCommonFlags + , setupDistPref + , setupVerbosity + , setupWorkingDir + , testCommonFlags , toFlag ) import qualified Distribution.Simple.Setup as Cabal - ( CopyFlags (..) - , Flag (..) - , RegisterFlags (..) - , TestFlags (..) - , copyCommand - , emptyCopyFlags - , emptyRegisterFlags - , registerCommand - , testCommand +import Distribution.Utils.Path hiding + ( (<.>) ) + import Distribution.Simple.Utils ( VerboseException , createDirectoryIfMissingVerbose @@ -293,7 +300,7 @@ -- | Installs the packages needed to satisfy a list of dependencies. install :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> Platform @@ -373,7 +380,7 @@ type InstallContext = ( InstalledPackageIndex , SourcePackageDb - , PkgConfigDb + , Maybe PkgConfigDb , [UserTarget] , [PackageSpecifier UnresolvedSourcePackage] , HttpTransport @@ -384,7 +391,7 @@ -- | Initial arguments given to 'install' or 'makeInstallContext'. type InstallArgs = - ( PackageDBStack + ( PackageDBStackCWD , RepoContext , Compiler , Platform @@ -559,7 +566,7 @@ -> InstallFlags -> InstalledPackageIndex -> SourcePackageDb - -> PkgConfigDb + -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Progress String String SolverInstallPlan planPackages @@ -1217,7 +1224,7 @@ regenerateHaddockIndex :: Verbosity - -> [PackageDB] + -> [PackageDBCWD] -> Compiler -> Platform -> ProgramDb @@ -1482,7 +1489,7 @@ distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags) + (setupDistPref $ configCommonFlags configFlags) setupScriptOptions index lock rpkg = configureSetupScript @@ -1698,7 +1705,7 @@ :: Verbosity -> PackageIdentifier -> ResolvedPkgLoc - -> FilePath + -> SymbolicPath Pkg (Dir Dist) -> (Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome installLocalPackage verbosity pkgid location distPref installPkg = @@ -1733,7 +1740,7 @@ :: Verbosity -> PackageIdentifier -> FilePath - -> FilePath + -> SymbolicPath Pkg (Dir Dist) -> (Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome installLocalTarballPackage @@ -1774,9 +1781,9 @@ -- fails even with this workaround. We probably can live with that. maybeRenameDistDir :: FilePath -> IO () maybeRenameDistDir absUnpackedPath = do - let distDirPath = absUnpackedPath defaultDistPref - distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") - distDirPathNew = absUnpackedPath distPref + let distDirPath = absUnpackedPath getSymbolicPath defaultDistPref + distDirPathTmp = absUnpackedPath (getSymbolicPath defaultDistPref ++ "-tmp") + distDirPathNew = absUnpackedPath getSymbolicPath distPref distDirExists <- doesDirectoryExist distDirPath when ( distDirExists @@ -1854,6 +1861,15 @@ ++ " with the latest revision from the index." writeFileAtomic descFilePath pkgtxt + let mbWorkDir = fmap makeSymbolicPath workingDir + commonFlags ver = + (`filterCommonFlags` ver) $ + defaultCommonSetupFlags + { setupDistPref = setupDistPref $ configCommonFlags configFlags + , setupVerbosity = toFlag verbosity' + , setupWorkingDir = maybeToFlag mbWorkDir + } + -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if -- the setup script was compiled against an old version of the Cabal lib). configFlags' <- addDefaultInstallDirs configFlags @@ -1862,9 +1878,34 @@ configureFlags = filterConfigureFlags configFlags' - { configVerbosity = toFlag verbosity' + { configCommonFlags = + (configCommonFlags (configFlags')) + { setupVerbosity = toFlag verbosity' + } } + buildFlags vers = + emptyBuildFlags{buildCommonFlags = commonFlags vers} + shouldHaddock = fromFlag (installDocumentation installFlags) + haddockFlags' vers = + haddockFlags{haddockCommonFlags = commonFlags vers} + testsEnabled = + fromFlag (configTests configFlags) + && fromFlagOrDefault False (installRunTests installFlags) + testFlags' vers = + (`filterTestFlags` vers) $ + testFlags{testCommonFlags = commonFlags vers} + copyFlags vers = + Cabal.emptyCopyFlags + { Cabal.copyDest = toFlag InstallDirs.NoCopyDest + , copyCommonFlags = commonFlags vers + } + shouldRegister = PackageDescription.hasLibs pkg + registerFlags vers = + Cabal.emptyRegisterFlags + { registerCommonFlags = commonFlags vers + } + -- Path to the optional log file. mLogPath <- maybeLogPath @@ -1872,19 +1913,19 @@ -- Configure phase onFailure ConfigureFailed $ do noticeProgress ProgressStarting - setup configureCommand configureFlags mLogPath + setup configureCommand configCommonFlags (return . configureFlags) mLogPath -- Build phase onFailure BuildFailed $ do noticeProgress ProgressBuilding - setup buildCommand' buildFlags mLogPath + setup buildCommand' buildCommonFlags (return . buildFlags) mLogPath -- Doc generation phase docsResult <- if shouldHaddock then ( do - setup haddockCommand haddockFlags' mLogPath + setup haddockCommand haddockCommonFlags (return . haddockFlags') mLogPath return DocsOk ) `catchIO` (\_ -> return DocsFailed) @@ -1894,7 +1935,7 @@ -- Tests phase onFailure TestsFailed $ do when (testsEnabled && PackageDescription.hasTests pkg) $ - setup Cabal.testCommand testFlags' mLogPath + setup Cabal.testCommand testCommonFlags (return . testFlags') mLogPath let testsResult | testsEnabled = TestsOk @@ -1911,11 +1952,14 @@ platform pkg $ do - setup Cabal.copyCommand copyFlags mLogPath + setup Cabal.copyCommand copyCommonFlags (return . copyFlags) mLogPath -- Capture installed package configuration file, so that -- it can be incorporated into the final InstallPlan - ipkgs <- genPkgConfs mLogPath + ipkgs <- + if shouldRegister + then genPkgConfs registerFlags mLogPath + else return [] let ipkgs' = case ipkgs of [ipkg] -> [ipkg{Installed.installedUnitId = uid}] _ -> ipkgs @@ -1928,6 +1972,7 @@ verbosity comp progdb + mbWorkDir packageDBs ipkg' defaultRegisterOptions @@ -1944,38 +1989,6 @@ noticeProgress phase = when isParallelBuild $ progressMessage verbosity phase dispname - - buildFlags _ = - emptyBuildFlags - { buildDistPref = configDistPref configFlags - , buildVerbosity = toFlag verbosity' - } - shouldHaddock = fromFlag (installDocumentation installFlags) - haddockFlags' _ = - haddockFlags - { haddockVerbosity = toFlag verbosity' - , haddockDistPref = configDistPref configFlags - } - testsEnabled = - fromFlag (configTests configFlags) - && fromFlagOrDefault False (installRunTests installFlags) - testFlags' = - filterTestFlags - testFlags - { Cabal.testDistPref = configDistPref configFlags - } - copyFlags _ = - Cabal.emptyCopyFlags - { Cabal.copyDistPref = configDistPref configFlags - , Cabal.copyDest = toFlag InstallDirs.NoCopyDest - , Cabal.copyVerbosity = toFlag verbosity' - } - shouldRegister = PackageDescription.hasLibs pkg - registerFlags _ = - Cabal.emptyRegisterFlags - { Cabal.regDistPref = configDistPref configFlags - , Cabal.regVerbosity = toFlag verbosity' - } verbosity' = maybe verbosity snd useLogFile tempTemplate name = name ++ "-" ++ prettyShow pkgid @@ -2001,30 +2014,32 @@ (configUserInstall configFlags') genPkgConfs - :: Maybe FilePath + :: (Version -> Cabal.RegisterFlags) + -> Maybe FilePath -> IO [Installed.InstalledPackageInfo] - genPkgConfs mLogPath = - if shouldRegister - then do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do - let pkgConfDest = dir "pkgConf" - registerFlags' version = - (registerFlags version) - { Cabal.regGenPkgConf = toFlag (Just pkgConfDest) - } - setup Cabal.registerCommand registerFlags' mLogPath - is_dir <- doesDirectoryExist pkgConfDest - let notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - if is_dir - then -- Sort so that each prefix of the package - -- configurations is well formed + genPkgConfs flags mLogPath = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do + let pkgConfDest = makeSymbolicPath dir makeRelativePathEx "pkgConf" + registerFlags' version = + (flags version) + { Cabal.regGenPkgConf = toFlag (Just pkgConfDest) + } + setup + Cabal.registerCommand + registerCommonFlags + (return . registerFlags') + mLogPath + is_dir <- doesDirectoryExist (interpretSymbolicPathCWD pkgConfDest) + let notHidden = not . isHidden + isHidden name = "." `isPrefixOf` name + if is_dir + then -- Sort so that each prefix of the package + -- configurations is well formed - traverse (readPkgConf pkgConfDest) . sort . filter notHidden - =<< getDirectoryContents pkgConfDest - else fmap (: []) $ readPkgConf "." pkgConfDest - else return [] + traverse (readPkgConf (getSymbolicPath pkgConfDest)) . sort . filter notHidden + =<< getDirectoryContents (getSymbolicPath pkgConfDest) + else fmap (: []) $ readPkgConf "." (getSymbolicPath pkgConfDest) readPkgConf :: FilePath @@ -2056,7 +2071,7 @@ when logFileExists $ removeFile logFileName return (Just logFileName) - setup cmd flags mLogPath = + setup cmd getCommonFlags flags mLogPath = Exception.bracket (traverse (\path -> openFile path AppendMode) mLogPath) (traverse_ hClose) @@ -2065,10 +2080,11 @@ verbosity scriptOptions { useLoggingHandle = logFileHandle - , useWorkingDir = workingDir + , useWorkingDir = makeSymbolicPath <$> workingDir } (Just pkg) cmd + getCommonFlags flags (const []) ) 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 @@ -84,6 +84,7 @@ import System.FilePath ( isAbsolute , joinPath + , normalise , splitPath , () ) @@ -98,7 +99,7 @@ import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) import Distribution.Client.Init.Prompt (promptYesNo) -import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt)) +import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt), runPromptIO) import Distribution.Client.Types.OverwritePolicy import qualified Data.ByteString as BS @@ -316,7 +317,7 @@ symlinkBinary inputs@Symlink{publicBindir, privateBindir, publicName, privateName} = do onSymlinkBinary mkLink overwrite (return False) maybeOverwrite inputs where - relativeBindir = makeRelative publicBindir privateBindir + relativeBindir = makeRelative (normalise publicBindir) privateBindir mkLink :: IO Bool mkLink = True <$ createFileLink (relativeBindir privateName) (publicBindir publicName) @@ -335,7 +336,7 @@ promptRun :: String -> IO Bool -> IO Bool promptRun s m = do - a <- promptYesNo s MandatoryPrompt + a <- runPromptIO $ promptYesNo s MandatoryPrompt if a then m else pure a -- | Check a file path of a symlink that we would like to create to see if it 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 @@ -43,9 +43,6 @@ import Distribution.Types.UnqualComponentName import Distribution.Simple.Compiler - ( Compiler - , PackageDBStack - ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Simple.Program (ProgramDb) @@ -141,7 +138,7 @@ -- | Return a list of packages matching given search strings. getPkgList :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Maybe (Compiler, ProgramDb) -> ListFlags @@ -213,7 +210,7 @@ -- | Show information about packages. list :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Maybe (Compiler, ProgramDb) -> ListFlags @@ -249,7 +246,7 @@ info :: Verbosity - -> PackageDBStack + -> PackageDBStackCWD -> RepoContext -> Compiler -> ProgramDb 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,6 +25,7 @@ ( ActAsSetupFlags (..) , BuildFlags (..) , CheckFlags (..) + , CommonSetupFlags (..) , ConfigExFlags (..) , ConfigFlags (..) , FetchFlags (..) @@ -49,6 +51,7 @@ , defaultConfigExFlags , defaultInstallFlags , fetchCommand + , filterCommonFlags , formatCommand , freezeCommand , genBoundsCommand @@ -83,7 +86,6 @@ , RegisterFlags (..) , ReplFlags (..) , TestFlags (..) - , configAbsolutePaths , defaultHaddockFlags , flagToMaybe , fromFlag @@ -181,6 +183,8 @@ , buildable ) +import Distribution.Client.Errors +import Distribution.Compat.ResponseFile import qualified Distribution.Make as Make import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription @@ -202,7 +206,7 @@ , defaultCommandFallback , hiddenCommand ) -import Distribution.Simple.Compiler (PackageDBStack) +import Distribution.Simple.Compiler (PackageDBStack, interpretPackageDBStack) import Distribution.Simple.Configure ( ConfigStateFileError (..) , configCompilerAuxEx @@ -237,6 +241,10 @@ ( display ) import qualified Distribution.Types.UnqualComponentName as Make +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import Distribution.Verbosity as Verbosity ( normal ) @@ -248,11 +256,8 @@ import Control.Exception (AssertionFailed, assert, try) import Data.Monoid (Any (..)) -import Distribution.Client.Errors -import Distribution.Compat.ResponseFile import System.Directory ( doesFileExist - , getCurrentDirectory , withCurrentDirectory ) import System.Environment (getEnvironment, getExecutablePath, getProgName) @@ -427,7 +432,7 @@ , regularCmd CmdPath.pathCommand CmdPath.pathAction , regularCmd genBoundsCommand genBoundsAction , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction - , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref + , wrapperCmd hscolourCommand hscolourCommonFlags , hiddenCmd formatCommand formatAction , hiddenCmd actAsSetupCommand actAsSetupAction , hiddenCmd manpageCommand (manpageAction commandSpecs) @@ -460,8 +465,8 @@ , legacyCmd testCommand testAction , legacyCmd benchmarkCommand benchmarkAction , legacyCmd cleanCommand cleanAction - , legacyWrapperCmd copyCommand copyVerbosity copyDistPref - , legacyWrapperCmd registerCommand regVerbosity regDistPref + , legacyWrapperCmd copyCommand copyCommonFlags + , legacyWrapperCmd registerCommand registerCommonFlags , legacyCmd reconfigureCommand reconfigureAction ] @@ -489,35 +494,40 @@ wrapperCmd :: Monoid flags => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) + -> (flags -> CommonSetupFlags) -> CommandSpec Action -wrapperCmd ui verbosity distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand +wrapperCmd ui getCommonFlags = + CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand wrapperAction :: Monoid flags => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) + -> (flags -> CommonSetupFlags) -> Command Action -wrapperAction command verbosityFlag distPrefFlag = +wrapperAction command getCommonFlags = commandAddAction command { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + let common = getCommonFlags flags + verbosity = fromFlagOrDefault normal $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions{useDistPref = distPref} + distPref <- findSavedDistPref config (setupDistPref common) + let setupScriptOptions = + defaultSetupScriptOptions + { useDistPref = distPref + , useWorkingDir = mbWorkDir + } setupWrapper verbosity setupScriptOptions Nothing command - (const flags) + getCommonFlags + (const (return flags)) (const extraArgs) configureAction @@ -525,11 +535,12 @@ -> [String] -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + let common = configCommonFlags configFlags + verbosity = fromFlagOrDefault normal $ setupVerbosity common config <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (configDistPref configFlags) + distPref <- getSymbolicPath <$> findSavedDistPref config (setupDistPref common) nixInstantiate verbosity distPref True globalFlags config nixShell verbosity distPref globalFlags config $ do let configFlags' = savedConfigureFlags config `mappend` configFlags @@ -549,7 +560,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> configure verbosity - packageDBs + (interpretPackageDBStack Nothing packageDBs) repoContext comp platform @@ -563,11 +574,12 @@ -> [String] -> Action reconfigureAction flags@(configFlags, _) _ globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + let common = configCommonFlags configFlags + verbosity = fromFlagOrDefault normal (setupVerbosity common) config <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (configDistPref configFlags) + distPref <- findSavedDistPref config (setupDistPref common) let checkFlags = Check $ \_ saved -> do let flags' = saved <> flags unless (saved == flags') $ info verbosity message @@ -579,7 +591,7 @@ message = "flags changed: " ++ unwords (commandShowOptions configureExCommand flags) - nixInstantiate verbosity distPref True globalFlags config + nixInstantiate verbosity (getSymbolicPath distPref) True globalFlags config _ <- reconfigure configureAction @@ -594,9 +606,10 @@ buildAction :: BuildFlags -> [String] -> Action buildAction buildFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + let common = buildCommonFlags buildFlags + verbosity = fromFlagOrDefault normal $ setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) + distPref <- findSavedDistPref config (setupDistPref common) -- Calls 'configureAction' to do the real work, so nothing special has to be -- done to support sandboxes. config' <- @@ -609,36 +622,49 @@ [] globalFlags config - nixShell verbosity distPref globalFlags config $ do + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do 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 -- 'reconfigure' twice. -build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () +build :: Verbosity -> SavedConfig -> SymbolicPath Pkg (Dir Dist) -> BuildFlags -> [String] -> IO () build verbosity config distPref buildFlags extraArgs = setupWrapper verbosity setupOptions Nothing (Cabal.buildCommand progDb) - mkBuildFlags + buildCommonFlags + (return . mkBuildFlags) (const extraArgs) where progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions{useDistPref = distPref} mkBuildFlags version = filterBuildFlags version config buildFlags' + commonFlags = buildCommonFlags buildFlags buildFlags' = buildFlags - { buildVerbosity = toFlag verbosity - , buildDistPref = toFlag distPref + { buildCommonFlags = + commonFlags + { setupVerbosity = toFlag verbosity + , setupDistPref = toFlag distPref + } } -- | Make sure that we don't pass new flags to setup scripts compiled against -- old versions of Cabal. filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags -filterBuildFlags version config buildFlags +filterBuildFlags version config buildFlags = + let flags' = filterBuildFlags' version config buildFlags + in flags' + { buildCommonFlags = + filterCommonFlags (buildCommonFlags flags') version + } + +filterBuildFlags' :: Version -> SavedConfig -> BuildFlags -> BuildFlags +filterBuildFlags' version config buildFlags | version >= mkVersion [1, 19, 1] = buildFlags_latest -- Cabal < 1.19.1 doesn't support 'build -j'. | otherwise = buildFlags_pre_1_19_1 @@ -659,11 +685,11 @@ replAction :: ReplFlags -> [String] -> Action replAction replFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) + let common = replCommonFlags replFlags + verbosity = fromFlagOrDefault normal $ setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (replDistPref replFlags) - cwd <- getCurrentDirectory - pkgDesc <- findPackageDesc cwd + distPref <- findSavedDistPref config (setupDistPref common) + pkgDesc <- findPackageDesc Nothing let -- There is a .cabal file in the current directory: start a REPL and load -- the project's modules. @@ -686,14 +712,25 @@ { useCabalVersion = orLaterVersion $ mkVersion [1, 18, 0] , useDistPref = distPref } + commonFlags = replCommonFlags replFlags replFlags' = replFlags - { replVerbosity = toFlag verbosity - , replDistPref = toFlag distPref + { replCommonFlags = + commonFlags + { setupVerbosity = toFlag verbosity + , setupDistPref = toFlag distPref + } } - nixShell verbosity distPref globalFlags config $ - setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs) + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ + setupWrapper + verbosity + setupOptions + Nothing + (Cabal.replCommand progDb) + Cabal.replCommonFlags + (const (return replFlags')) + (const extraArgs) -- No .cabal file in the current directory: just start the REPL (possibly -- using the sandbox package DB). @@ -706,7 +743,7 @@ (replProgramPaths replFlags) (replProgramArgs replFlags) programDb - nixShell verbosity distPref globalFlags config $ do + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do startInterpreter verbosity programDb' @@ -728,16 +765,18 @@ -> Action installAction (configFlags, _, installFlags, _, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) + let common = configCommonFlags configFlags + verb = fromFlagOrDefault normal (setupVerbosity common) config <- loadConfigOrSandboxConfig verb globalFlags - dist <- findSavedDistPref config (configDistPref configFlags) + dist <- findSavedDistPref config (setupDistPref common) let setupOpts = defaultSetupScriptOptions{useDistPref = dist} setupWrapper verb setupOpts Nothing installCommand - (const (mempty, mempty, mempty, mempty, mempty, mempty)) + (const common) + (const (return (mempty, mempty, mempty, mempty, mempty, mempty))) (const []) installAction ( configFlags @@ -749,12 +788,13 @@ ) extraArgs globalFlags = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) + let common = configCommonFlags configFlags + verb = fromFlagOrDefault normal $ setupVerbosity common config <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verb globalFlags - dist <- findSavedDistPref config (configDistPref configFlags) + dist <- findSavedDistPref config $ setupDistPref common do targets <- readUserTargets verb extraArgs @@ -762,7 +802,12 @@ let configFlags' = maybeForceTests installFlags' $ savedConfigureFlags config - `mappend` configFlags{configDistPref = toFlag dist} + `mappend` configFlags + { configCommonFlags = + (configCommonFlags configFlags) + { setupDistPref = toFlag dist + } + } configExFlags' = defaultConfigExFlags `mappend` savedConfigureExFlags config @@ -774,15 +819,30 @@ haddockFlags' = defaultHaddockFlags `mappend` savedHaddockFlags config - `mappend` haddockFlags{haddockDistPref = toFlag dist} + `mappend` haddockFlags + { haddockCommonFlags = + (haddockCommonFlags haddockFlags) + { setupDistPref = toFlag dist + } + } testFlags' = Cabal.defaultTestFlags `mappend` savedTestFlags config - `mappend` testFlags{testDistPref = toFlag dist} + `mappend` testFlags + { testCommonFlags = + (testCommonFlags testFlags) + { setupDistPref = toFlag dist + } + } benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` savedBenchmarkFlags config - `mappend` benchmarkFlags{benchmarkDistPref = toFlag dist} + `mappend` benchmarkFlags + { benchmarkCommonFlags = + (benchmarkCommonFlags benchmarkFlags) + { setupDistPref = toFlag dist + } + } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags' @@ -790,18 +850,16 @@ -- future. progdb' <- configureAllKnownPrograms verb progdb - configFlags'' <- configAbsolutePaths configFlags' - withRepoContext verb globalFlags' $ \repoContext -> install verb - (configPackageDB' configFlags'') + (interpretPackageDBStack Nothing (configPackageDB' configFlags')) repoContext comp platform progdb' globalFlags' - configFlags'' + configFlags' configExFlags' installFlags' haddockFlags' @@ -821,12 +879,15 @@ -> GlobalFlags -> IO () testAction (buildFlags, testFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + let verbosity = fromFlagOrDefault normal (setupVerbosity $ buildCommonFlags buildFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (testDistPref testFlags) + distPref <- findSavedDistPref config (setupDistPref $ testCommonFlags testFlags) let buildFlags' = buildFlags - { buildVerbosity = testVerbosity testFlags + { buildCommonFlags = + (buildCommonFlags buildFlags) + { setupVerbosity = setupVerbosity $ testCommonFlags testFlags + } } checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> if fromFlagOrDefault False (configTests configFlags) @@ -849,14 +910,20 @@ [] globalFlags config - nixShell verbosity distPref globalFlags config $ do + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do let setupOptions = defaultSetupScriptOptions{useDistPref = distPref} - testFlags' = testFlags{testDistPref = toFlag 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) @@ -870,7 +937,14 @@ | otherwise = extraArgs build verbosity config distPref buildFlags' extraArgs' - setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs') + setupWrapper + verbosity + setupOptions + Nothing + Cabal.testCommand + Cabal.testCommonFlags + (const (return testFlags')) + (const extraArgs') data ComponentNames = ComponentNamesUnknown @@ -879,12 +953,14 @@ -- | Return the names of all buildable components matching a given predicate. componentNamesFromLBI :: Verbosity - -> FilePath + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> SymbolicPath Pkg (Dir Dist) -> String -> (LBI.Component -> Bool) -> IO ComponentNames -componentNamesFromLBI verbosity distPref targetsDescr compPred = do - eLBI <- tryGetPersistBuildConfig distPref +componentNamesFromLBI verbosity mbWorkDir distPref targetsDescr compPred = do + eLBI <- tryGetPersistBuildConfig mbWorkDir distPref case eLBI of Left err -> case err of -- Note: the build config could have been generated by a custom setup @@ -920,13 +996,16 @@ let verbosity = fromFlagOrDefault normal - (buildVerbosity buildFlags) + (setupVerbosity $ buildCommonFlags buildFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) + distPref <- findSavedDistPref config (setupDistPref $ benchmarkCommonFlags benchmarkFlags) let buildFlags' = buildFlags - { buildVerbosity = benchmarkVerbosity benchmarkFlags + { buildCommonFlags = + (buildCommonFlags buildFlags) + { setupVerbosity = setupVerbosity $ benchmarkCommonFlags benchmarkFlags + } } let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> @@ -950,14 +1029,22 @@ [] globalFlags config - nixShell verbosity distPref globalFlags config $ do + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do let setupOptions = defaultSetupScriptOptions{useDistPref = distPref} - benchmarkFlags' = benchmarkFlags{benchmarkDistPref = toFlag 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) @@ -971,13 +1058,21 @@ | otherwise = extraArgs build verbosity config' distPref buildFlags' extraArgs' - setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') + setupWrapper + verbosity + setupOptions + Nothing + Cabal.benchmarkCommand + Cabal.benchmarkCommonFlags + (const (return benchmarkFlags')) + (const extraArgs') haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do - let verbosity = fromFlag (haddockVerbosity haddockFlags) + let common = haddockCommonFlags haddockFlags + verbosity = fromFlag $ setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (haddockDistPref haddockFlags) + distPref <- findSavedDistPref config (setupDistPref common) config' <- reconfigure configureAction @@ -988,11 +1083,17 @@ [] globalFlags config - nixShell verbosity distPref globalFlags config $ do + let mbWorkDir = flagToMaybe $ setupWorkingDir common + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do let haddockFlags' = defaultHaddockFlags `mappend` savedHaddockFlags config' - `mappend` haddockFlags{haddockDistPref = toFlag distPref} + `mappend` haddockFlags + { haddockCommonFlags = + (haddockCommonFlags haddockFlags) + { setupDistPref = toFlag distPref + } + } setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref @@ -1002,36 +1103,44 @@ setupScriptOptions Nothing haddockCommand - (const haddockFlags') + haddockCommonFlags + (const (return haddockFlags')) (const extraArgs) when (haddockForHackage haddockFlags == Flag ForHackage) $ do - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - let dest = distPref name <.> "tar.gz" + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref) + let dest = getSymbolicPath distPref name <.> "tar.gz" name = display (packageId pkg) ++ "-docs" - docDir = distPref "doc" "html" + 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 load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (cleanDistPref cleanFlags) + distPref <- findSavedDistPref config $ setupDistPref common let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref , useWin32CleanHack = True } - cleanFlags' = cleanFlags{cleanDistPref = toFlag distPref} + cleanFlags' = + cleanFlags + { cleanCommonFlags = + (cleanCommonFlags cleanFlags) + { setupDistPref = toFlag distPref + } + } setupWrapper verbosity setupScriptOptions Nothing cleanCommand - (const cleanFlags') + cleanCommonFlags + (const (return cleanFlags')) (const extraArgs) - where - verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do @@ -1055,7 +1164,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> List.list verbosity - (configPackageDB' configFlags) + (interpretPackageDBStack Nothing (configPackageDB' configFlags)) repoContext compProgdb listFlags @@ -1078,7 +1187,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> List.info verbosity - (configPackageDB' configFlags) + (interpretPackageDBStack Nothing (configPackageDB' configFlags)) repoContext comp progdb @@ -1097,7 +1206,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> fetch verbosity - (configPackageDB' configFlags) + (interpretPackageDBStack Nothing (configPackageDB' configFlags)) repoContext comp platform @@ -1111,7 +1220,7 @@ let verbosity = fromFlag (freezeVerbosity freezeFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config NoFlag - nixShell verbosity distPref globalFlags config $ do + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags @@ -1119,7 +1228,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> freeze verbosity - (configPackageDB' configFlags) + (interpretPackageDBStack Nothing (configPackageDB' configFlags)) repoContext comp platform @@ -1132,7 +1241,7 @@ let verbosity = fromFlag (freezeVerbosity freezeFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config NoFlag - nixShell verbosity distPref globalFlags config $ do + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags @@ -1140,7 +1249,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> genBounds verbosity - (configPackageDB' configFlags) + (interpretPackageDBStack Nothing (configPackageDB' configFlags)) repoContext comp platform @@ -1217,8 +1326,9 @@ [] globalFlags distPref <- findSavedDistPref config NoFlag - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" + let mbWorkDir = flagToMaybe $ configWorkingDir $ savedConfigureFlags config + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref) + return $ getSymbolicPath distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" checkAction :: CheckFlags -> [String] -> Action checkAction checkFlags extraArgs _globalFlags = do @@ -1234,13 +1344,11 @@ formatAction verbosityFlag extraArgs _globalFlags = do let verbosity = fromFlag verbosityFlag path <- case extraArgs of - [] -> do - cwd <- getCurrentDirectory - tryFindPackageDesc verbosity cwd - (p : _) -> return p - pkgDesc <- readGenericPackageDescription verbosity path + [] -> relativeSymbolicPath <$> tryFindPackageDesc verbosity Nothing + (p : _) -> return $ makeSymbolicPath p + pkgDesc <- readGenericPackageDescription verbosity Nothing path -- Uses 'writeFileAtomic' under the hood. - writeGenericPackageDescription path pkgDesc + writeGenericPackageDescription (getSymbolicPath path) pkgDesc reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do @@ -1262,9 +1370,10 @@ runAction :: BuildFlags -> [String] -> Action runAction buildFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + let common = buildCommonFlags buildFlags + verbosity = fromFlagOrDefault normal $ setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) + distPref <- findSavedDistPref config $ setupDistPref common config' <- reconfigure configureAction @@ -1275,8 +1384,9 @@ [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - lbi <- getPersistBuildConfig distPref + let mbWorkDir = flagToMaybe $ setupWorkingDir common + nixShell verbosity (getSymbolicPath distPref) globalFlags config $ do + lbi <- getPersistBuildConfig mbWorkDir distPref (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] @@ -1323,7 +1433,7 @@ withRepoContext verbosity globalFlags' $ \repoContext -> initCmd verbosity - (configPackageDB' confFlags') + (interpretPackageDBStack Nothing (configPackageDB' confFlags')) repoContext comp progdb @@ -1360,10 +1470,11 @@ in case bt of Simple -> Simple.defaultMainArgs args Configure -> - Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks + Simple.defaultMainWithSetupHooksArgs + Simple.autoconfSetupHooks args Make -> Make.defaultMainArgs args + Hooks -> error "actAsSetupAction Hooks" Custom -> error "actAsSetupAction Custom" manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action 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 @@ -8,13 +8,19 @@ ( NixStyleFlags (..) , nixStyleOptions , defaultNixStyleFlags + , updNixStyleCommonSetupFlags ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) -import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) +import Distribution.Simple.Setup + ( BenchmarkFlags (benchmarkCommonFlags) + , CommonSetupFlags (..) + , HaddockFlags (..) + , TestFlags (testCommonFlags) + ) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Client.ProjectFlags @@ -125,4 +131,28 @@ , benchmarkFlags = mempty , projectFlags = defaultProjectFlags , extraFlags = x + } + +updNixStyleCommonSetupFlags + :: (CommonSetupFlags -> CommonSetupFlags) + -> NixStyleFlags a + -> NixStyleFlags a +updNixStyleCommonSetupFlags setFlag nixFlags = + nixFlags + { configFlags = + let flags = configFlags nixFlags + common = configCommonFlags flags + in flags{configCommonFlags = setFlag common} + , haddockFlags = + let flags = haddockFlags nixFlags + common = haddockCommonFlags flags + in flags{haddockCommonFlags = setFlag common} + , testFlags = + let flags = testFlags nixFlags + common = testCommonFlags flags + in flags{testCommonFlags = setFlag common} + , benchmarkFlags = + let flags = benchmarkFlags nixFlags + common = benchmarkCommonFlags flags + in flags{benchmarkCommonFlags = setFlag common} } 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 @@ -44,7 +44,7 @@ , CompilerId , DebugInfoLevel (..) , OptimisationLevel (..) - , PackageDB + , PackageDBCWD , ProfDetailLevel (..) , showProfDetailLevel ) @@ -221,7 +221,7 @@ , pkgHashExtraIncludeDirs :: [FilePath] , pkgHashProgPrefix :: Maybe PathTemplate , pkgHashProgSuffix :: Maybe PathTemplate - , pkgHashPackageDbs :: [Maybe PackageDB] + , pkgHashPackageDbs :: [Maybe PackageDBCWD] , -- Haddock options pkgHashDocumentation :: Bool , pkgHashHaddockHoogle :: Bool @@ -238,8 +238,9 @@ , pkgHashHaddockContents :: Maybe PathTemplate , pkgHashHaddockIndex :: Maybe PathTemplate , pkgHashHaddockBaseUrl :: Maybe String - , pkgHashHaddockLib :: Maybe String + , pkgHashHaddockResourcesDir :: Maybe String , pkgHashHaddockOutputDir :: Maybe FilePath + , pkgHashHaddockUseUnicode :: Bool -- TODO: [required eventually] pkgHashToolsVersions ? -- TODO: [required eventually] pkgHashToolsExtraOptions ? } @@ -347,8 +348,9 @@ , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents , opt "haddock-index-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockIndex , opt "haddock-base-url" Nothing (fromMaybe "") pkgHashHaddockBaseUrl - , opt "haddock-lib" Nothing (fromMaybe "") pkgHashHaddockLib + , opt "haddock-resources-dir" Nothing (fromMaybe "") pkgHashHaddockResourcesDir , opt "haddock-output-dir" Nothing (fromMaybe "") pkgHashHaddockOutputDir + , opt "haddock-use-unicode" False prettyShow pkgHashHaddockUseUnicode ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs where 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 @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -71,15 +72,15 @@ import Distribution.Package import Distribution.Simple.Compiler - ( Compiler - , PackageDB (..) - , jsemSupported - ) import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import Distribution.Compat.Graph (IsNode (..)) import Distribution.Simple.Utils +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import Distribution.Version import qualified Data.Map as Map @@ -89,7 +90,7 @@ import Control.Exception (assert, bracket, handle) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) -import System.FilePath (makeRelative, takeDirectory, (<.>), ()) +import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), ()) import System.Semaphore (SemaphoreName (..)) import Distribution.Client.Errors @@ -473,7 +474,7 @@ :: Verbosity -> Compiler -> ProgramDb - -> PackageDB + -> PackageDBCWD -> IO () createPackageDBIfMissing verbosity @@ -533,7 +534,7 @@ case pkgBuildStatus of BuildStatusDownload -> downloadPhase BuildStatusUnpack tarball -> unpackTarballPhase tarball - BuildStatusRebuild srcdir status -> rebuildPhase status srcdir + BuildStatusRebuild srcdir status -> rebuildPhase status (makeSymbolicPath srcdir) -- TODO: perhaps re-nest the types to make these impossible BuildStatusPreExisting{} -> unexpectedState BuildStatusInstalled{} -> unexpectedState @@ -570,7 +571,7 @@ -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages -- would only start from download or unpack phases. -- - rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult + rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult rebuildPhase buildStatus srcdir = assert (isInplaceBuildStyle $ elabBuildStyle pkg) @@ -579,11 +580,13 @@ srcdir builddir where + distdir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) builddir = - distBuildDirectory - (elabDistDirParams sharedPackageConfig pkg) + makeSymbolicPath $ + makeRelative (normalise $ getSymbolicPath srcdir) distdir + -- TODO: [nice to have] ^^ do this relative stuff better - buildAndInstall :: FilePath -> FilePath -> IO BuildResult + buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage verbosity @@ -597,12 +600,9 @@ plan rpkg srcdir - builddir' - where - builddir' = makeRelative srcdir builddir - -- TODO: [nice to have] ^^ do this relative stuff better + builddir - buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult + buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildInplace buildStatus srcdir builddir = -- TODO: [nice to have] use a relative build dir rather than absolute buildInplaceUnpackedPackage @@ -698,8 +698,8 @@ -> DistDirParams -> BuildStyle -> Maybe CabalFileText - -> ( FilePath -- Source directory - -> FilePath -- Build directory + -> ( SymbolicPath CWD (Dir Pkg) -- Source directory + -> SymbolicPath Pkg (Dir Dist) -- Build directory -> IO a ) -> IO a @@ -723,15 +723,15 @@ -- this way we avoid breaking those packages BuildAndInstall -> let tmpdir = distTempDirectory + builddir = relativeSymbolicPath $ makeRelativePathEx "dist" in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + let srcdir = makeSymbolicPath $ unpackdir prettyShow pkgid unpackPackageTarball verbosity tarball unpackdir pkgid pkgTextOverride - let srcdir = unpackdir prettyShow pkgid - builddir = srcdir "dist" buildPkg srcdir builddir -- In this case we make sure the tarball has been unpacked to the @@ -740,10 +740,14 @@ BuildInplaceOnly{} -> do let srcrootdir = distUnpackedSrcRootDirectory srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory dparams + builddir = + makeSymbolicPath $ + makeRelative (normalise srcdir) $ + distBuildDirectory dparams + -- TODO: [nice to have] ^^ do this relative stuff better + exists <- doesDirectoryExist srcdir -- TODO: [nice to have] use a proper file monitor rather -- than this dir exists test - exists <- doesDirectoryExist srcdir unless exists $ do createDirectoryIfMissingVerbose verbosity True srcrootdir unpackPackageTarball @@ -758,7 +762,7 @@ srcrootdir pkgid dparams - buildPkg srcdir builddir + buildPkg (makeSymbolicPath srcdir) builddir 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 @@ -26,7 +26,7 @@ ) import qualified Data.Set as Set -import Distribution.Client.Init.Types (removeExistingFile) +import Distribution.Client.Init.Types (removeExistingFile, runPromptIO) ----------------------------- -- Package change detection @@ -291,4 +291,4 @@ invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = - removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) + runPromptIO $ removeExistingFile (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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -42,7 +43,9 @@ import Distribution.Client.FileMonitor import Distribution.Client.JobControl import Distribution.Client.Setup - ( filterConfigureFlags + ( CommonSetupFlags + , filterCommonFlags + , filterConfigureFlags , filterHaddockArgs , filterHaddockFlags , filterTestFlags @@ -70,7 +73,8 @@ import Distribution.Simple.BuildPaths (haddockDirName) import Distribution.Simple.Command (CommandUI) import Distribution.Simple.Compiler - ( PackageDBStack + ( PackageDBStackCWD + , coercePackageDBStack ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo @@ -85,6 +89,10 @@ import Distribution.Simple.Utils import Distribution.System (Platform (..)) +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import Distribution.Version import qualified Data.ByteString as BS @@ -126,7 +134,7 @@ | PBInstallPhase { runCopy :: FilePath -> IO () , runRegister - :: PackageDBStack + :: PackageDBStackCWD -> Cabal.RegisterOptions -> IO InstalledPackageInfo } @@ -151,9 +159,9 @@ -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage - -> FilePath - -> FilePath - -> Maybe (FilePath) + -> SymbolicPath CWD (Dir Pkg) + -> SymbolicPath Pkg (Dir Dist) + -> Maybe FilePath -- ^ The path to an /initialized/ log file -> (PackageBuildingPhase -> IO ()) -> IO () @@ -161,7 +169,7 @@ verbosity distDirLayout@DistDirLayout{distTempDirectory} maybe_semaphore - BuildTimeSettings{buildSettingNumJobs} + buildTimeSettings@BuildTimeSettings{buildSettingNumJobs} registerLock cacheLock pkgshared@ElaboratedSharedConfig @@ -178,27 +186,27 @@ delegate $ PBConfigurePhase $ annotateFailure mlogFile ConfigureFailed $ - setup configureCommand configureFlags configureArgs + setup configureCommand Cabal.configCommonFlags configureFlags configureArgs -- Build phase delegate $ PBBuildPhase $ annotateFailure mlogFile BuildFailed $ do - setup buildCommand buildFlags buildArgs + setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs -- Haddock phase whenHaddock $ delegate $ PBHaddockPhase $ annotateFailure mlogFile HaddocksFailed $ do - setup haddockCommand haddockFlags haddockArgs + setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs -- Install phase delegate $ PBInstallPhase { runCopy = \destdir -> annotateFailure mlogFile InstallFailed $ - setup Cabal.copyCommand (copyFlags destdir) copyArgs + setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do -- We register ourselves rather than via Setup.hs. We need to @@ -211,7 +219,8 @@ verbosity compiler progdb - pkgDBStack + Nothing + (coercePackageDBStack pkgDBStack) ipkg registerOpts return ipkg @@ -222,21 +231,21 @@ delegate $ PBTestPhase $ annotateFailure mlogFile TestsFailed $ - setup testCommand testFlags testArgs + setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs -- Bench phase whenBench $ delegate $ PBBenchPhase $ annotateFailure mlogFile BenchFailed $ - setup benchCommand benchFlags benchArgs + setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs -- Repl phase whenRepl $ delegate $ PBReplPhase $ annotateFailure mlogFile ReplFailed $ - setupInteractive replCommand replFlags replArgs + setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs return () where @@ -262,27 +271,31 @@ | hasValidHaddockTargets pkg = action | otherwise = return () + mbWorkDir = useWorkingDir scriptOptions + commonFlags v = + flip filterCommonFlags v $ + setupHsCommonFlags verbosity mbWorkDir builddir + configureCommand = Cabal.configureCommand defaultProgramDb configureFlags v = - flip filterConfigureFlags v $ - setupHsConfigureFlags + flip filterConfigureFlags v + <$> setupHsConfigureFlags + (\p -> makeSymbolicPath <$> canonicalizePath p) plan rpkg pkgshared - verbosity - builddir + (commonFlags v) configureArgs _ = setupHsConfigureArgs pkg buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir + buildFlags v = setupHsBuildFlags comp_par_strat pkg pkgshared $ commonFlags v buildArgs _ = setupHsBuildArgs pkg - copyFlags destdir _ = + copyFlags destdir v = setupHsCopyFlags pkg pkgshared - verbosity - builddir + (commonFlags 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. @@ -293,26 +306,23 @@ flip filterTestFlags v $ setupHsTestFlags pkg - verbosity - builddir + (commonFlags v) testArgs _ = setupHsTestArgs pkg benchCommand = Cabal.benchmarkCommand - benchFlags _ = + benchFlags v = setupHsBenchFlags pkg pkgshared - verbosity - builddir + (commonFlags v) benchArgs _ = setupHsBenchArgs pkg replCommand = Cabal.replCommand defaultProgramDb - replFlags _ = + replFlags v = setupHsReplFlags pkg pkgshared - verbosity - builddir + (commonFlags v) replArgs _ = setupHsReplArgs pkg haddockCommand = Cabal.haddockCommand @@ -321,8 +331,8 @@ setupHsHaddockFlags pkg pkgshared - verbosity - builddir + buildTimeSettings + (commonFlags v) haddockArgs v = flip filterHaddockArgs v $ setupHsHaddockArgs pkg @@ -340,11 +350,12 @@ setup :: CommandUI flags - -> (Version -> flags) + -> (flags -> CommonSetupFlags) + -> (Version -> IO flags) -> (Version -> [String]) -> IO () - setup cmd flags args = - withLogging $ \mLogFileHandle -> + setup cmd getCommonFlags flags args = + withLogging $ \mLogFileHandle -> do setupWrapper verbosity scriptOptions @@ -356,21 +367,24 @@ } (Just (elabPkgDescription pkg)) cmd + getCommonFlags flags args setupInteractive :: CommandUI flags + -> (flags -> CommonSetupFlags) -> (Version -> flags) -> (Version -> [String]) -> IO () - setupInteractive cmd flags args = + setupInteractive cmd getCommonFlags flags args = setupWrapper verbosity scriptOptions{isInteractive = True} (Just (elabPkgDescription pkg)) cmd - flags + getCommonFlags + (\v -> return (flags v)) args generateInstalledPackageInfo :: IO InstalledPackageInfo @@ -379,14 +393,13 @@ verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = + let registerFlags v = setupHsRegisterFlags pkg pkgshared - verbosity - builddir + (commonFlags v) pkgConfDest - setup Cabal.registerCommand registerFlags (const []) + setup (Cabal.registerCommand) Cabal.registerCommonFlags (\v -> return (registerFlags v)) (const []) withLogging :: (Maybe Handle -> IO r) -> IO r withLogging action = @@ -411,8 +424,8 @@ -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> BuildStatusRebuild - -> FilePath - -> FilePath + -> SymbolicPath CWD (Dir Pkg) + -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildInplaceUnpackedPackage verbosity @@ -434,7 +447,7 @@ -- TODO: [code cleanup] there is duplication between the -- distdirlayout and the builddir here builddir is not -- enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose verbosity True $ getSymbolicPath builddir createDirectoryIfMissingVerbose verbosity True @@ -464,7 +477,7 @@ whenReConfigure $ do runConfigure invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg PBBuildPhase{runBuild} -> do whenRebuild $ do timestamp <- beginUpdateFileMonitor @@ -475,10 +488,10 @@ `onException` invalidatePackageRegFileMonitor packageFileMonitor let listSimple = - execRebuild srcdir (needElaboratedConfiguredPackage pkg) + execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg) listSdist = fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity srcdir + allPackageSourceFiles verbosity (getSymbolicPath srcdir) ifNullThen m m' = do xs <- m if null xs then m' else return xs @@ -511,7 +524,7 @@ pkg updatePackageBuildFileMonitor packageFileMonitor - srcdir + (getSymbolicPath srcdir) timestamp pkg buildStatus @@ -558,7 +571,7 @@ return (Just ipkg) else return Nothing - updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg PBTestPhase{runTest} -> runTest PBBenchPhase{runBench} -> runBench PBReplPhase{runRepl} -> runRepl @@ -617,8 +630,8 @@ -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage - -> FilePath - -> FilePath + -> SymbolicPath CWD (Dir Pkg) + -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildAndInstallUnpackedPackage verbosity @@ -638,7 +651,7 @@ rpkg@(ReadyPackage pkg) srcdir builddir = do - createDirectoryIfMissingVerbose verbosity True (srcdir builddir) + createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPath (Just srcdir) builddir) -- TODO: [code cleanup] deal consistently with talking to older -- Setup.hs versions, much like we do for ghc, with a proper 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 @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- | Handling project configuration. module Distribution.Client.ProjectConfig @@ -18,8 +19,10 @@ -- * Project root , findProjectRoot + , getProjectRootUsability , ProjectRoot (..) - , BadProjectRoot + , BadProjectRoot (..) + , ProjectRootUsability (..) -- * Project config files , readProjectConfig @@ -34,6 +37,7 @@ , writeProjectLocalFreezeConfig , writeProjectConfigFile , commandLineFlagsToProjectConfig + , onlyTopLevelProvenance -- * Packages within projects , ProjectPackageLocation (..) @@ -93,6 +97,7 @@ ( RepoContext (..) , withRepoContext' ) +import Distribution.Client.HashValue import Distribution.Client.HttpUtils ( HttpTransport , configureTransport @@ -102,12 +107,12 @@ import Distribution.Client.Types import Distribution.Client.Utils.Parsec (renderParseError) +import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint - ( PackageProperty (..) - ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import Distribution.Client.Errors import Distribution.Client.Setup ( defaultMaxBackjumps , defaultSolver @@ -115,6 +120,7 @@ import Distribution.Client.SrcDist ( packageDirToSdist ) +import Distribution.Client.Targets import Distribution.Client.Types.SourceRepo ( SourceRepoList , SourceRepositoryPackage (..) @@ -135,11 +141,6 @@ , showPWarning ) import Distribution.Package - ( PackageId - , PackageName - , UnitId - , packageId - ) import Distribution.PackageDescription.Parsec ( parseGenericPackageDescription ) @@ -186,6 +187,10 @@ import Distribution.Types.SourceRepo ( RepoType (..) ) +import Distribution.Utils.Generic + ( toUTF8BS + , toUTF8LBS + ) import Distribution.Utils.NubList ( fromNubList ) @@ -194,24 +199,20 @@ , verbose ) import Distribution.Version - ( Version - ) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Client.Tar as Tar +import Control.Exception (handle) import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import qualified Data.Hashable as Hashable import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set -import Numeric (showHex) -import Distribution.Client.Errors import Network.URI ( URI (..) , URIAuth (..) @@ -219,6 +220,15 @@ , uriToString ) import System.Directory + ( canonicalizePath + , doesDirectoryExist + , doesFileExist + , doesPathExist + , getCurrentDirectory + , getDirectoryContents + , getHomeDirectory + , pathIsSymbolicLink + ) import System.FilePath hiding (combine) import System.IO ( IOMode (ReadMode) @@ -310,9 +320,34 @@ where -- TODO: [required eventually] some of these settings need validation, e.g. -- the flag assignments need checking. + cabalPkgname = mkPackageName "Cabal" + + profilingDynamicConstraint = + ( UserConstraint + (UserAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) + , ConstraintSourceProfiledDynamic + ) + + profDynEnabledGlobally = fromFlagOrDefault False (packageConfigProfShared projectConfigLocalPackages) + + profDynEnabledAnyLocally = + or + [ fromFlagOrDefault False (packageConfigProfShared ppc) + | (_, ppc) <- Map.toList (getMapMappend projectConfigSpecificPackage) + ] + + -- Add a setup.Cabal >= 3.13 constraint if prof+dyn is enabled globally + -- or any package in the project enables it. + -- Ideally we'd apply this constraint only on the closure of packages requiring prof+dyn, + -- but that would require another solver run for marginal advantages that + -- will further shrink as 3.13 is adopted. + solverCabalLibConstraints = + [profilingDynamicConstraint | profDynEnabledGlobally || profDynEnabledAnyLocally] + solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - solverSettingConstraints = projectConfigConstraints + solverSettingConstraints = solverCabalLibConstraints ++ projectConfigConstraints solverSettingPreferences = projectConfigPreferences solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages solverSettingFlagAssignments = @@ -504,6 +539,24 @@ -- Reading and writing project config files -- +-- | Get @ProjectRootUsability@ of a given file +getProjectRootUsability :: FilePath -> IO ProjectRootUsability +getProjectRootUsability filePath = do + exists <- doesFileExist filePath + if exists + then return ProjectRootUsabilityPresentAndUsable + else do + let isUsableAction = + handle @IOException + -- NOTE: if any IOException is raised, we assume the file does not exist. + -- That is what happen when we call @pathIsSymbolicLink@ on a @FilePath@ that does not exist. + (const $ pure False) + ((||) <$> pathIsSymbolicLink filePath <*> doesPathExist filePath) + isUnusable <- isUsableAction + if isUnusable + then return ProjectRootUsabilityPresentAndUnusable + else return ProjectRootUsabilityNotPresent + -- | Find the root of this project. -- -- The project directory will be one of the following: @@ -527,13 +580,18 @@ "Specifying an absolute path to the project file is deprecated." <> " Use --project-dir to set the project's directory." - doesFileExist file >>= \case - False -> left (BadProjectRootExplicitFile file) - True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file + getProjectRootUsability file >>= \case + ProjectRootUsabilityPresentAndUsable -> + uncurry projectRoot + =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file + ProjectRootUsabilityNotPresent -> + left (BadProjectRootExplicitFileNotFound file) + ProjectRootUsabilityPresentAndUnusable -> + left (BadProjectRootFileBroken file) | otherwise -> probeProjectRoot mprojectFile Just dir -> doesDirectoryExist dir >>= \case - False -> left (BadProjectRootDir dir) + False -> left (BadProjectRootDirNotFound dir) True -> do projectDir <- canonicalizePath dir @@ -541,13 +599,21 @@ Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile) Just projectFile | isAbsolute projectFile -> - doesFileExist projectFile >>= \case - False -> left (BadProjectRootAbsoluteFile projectFile) - True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile + getProjectRootUsability projectFile >>= \case + ProjectRootUsabilityNotPresent -> + left (BadProjectRootAbsoluteFileNotFound projectFile) + ProjectRootUsabilityPresentAndUsable -> + Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile + ProjectRootUsabilityPresentAndUnusable -> + left (BadProjectRootFileBroken projectFile) | otherwise -> - doesFileExist (projectDir projectFile) >>= \case - False -> left (BadProjectRootDirFile dir projectFile) - True -> projectRoot projectDir projectFile + getProjectRootUsability (projectDir projectFile) >>= \case + ProjectRootUsabilityNotPresent -> + left (BadProjectRootDirFileNotFound dir projectFile) + ProjectRootUsabilityPresentAndUsable -> + projectRoot projectDir projectFile + ProjectRootUsabilityPresentAndUnusable -> + left (BadProjectRootFileBroken projectFile) where left = pure . Left @@ -556,7 +622,7 @@ probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot) probeProjectRoot mprojectFile = do - startdir <- getCurrentDirectory + startdir <- System.Directory.getCurrentDirectory homedir <- getHomeDirectory probe startdir homedir where @@ -572,46 +638,51 @@ go dir | isDrive dir || dir == homedir = case mprojectFile of Nothing -> return (Right (ProjectRootImplicit startdir)) - Just file -> return (Left (BadProjectRootExplicitFile file)) + Just file -> return (Left (BadProjectRootExplicitFileNotFound file)) go dir = do - exists <- doesFileExist (dir projectFileName) - if exists - then return (Right (ProjectRootExplicit dir projectFileName)) - else go (takeDirectory dir) + getProjectRootUsability (dir projectFileName) >>= \case + ProjectRootUsabilityNotPresent -> + go (takeDirectory dir) + ProjectRootUsabilityPresentAndUsable -> + return (Right $ ProjectRootExplicit dir projectFileName) + ProjectRootUsabilityPresentAndUnusable -> + return (Left $ BadProjectRootFileBroken projectFileName) -- | Errors returned by 'findProjectRoot'. data BadProjectRoot - = BadProjectRootExplicitFile FilePath - | BadProjectRootDir FilePath - | BadProjectRootAbsoluteFile FilePath - | BadProjectRootDirFile FilePath FilePath -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadProjectRoot where - show = renderBadProjectRoot -#endif + = BadProjectRootExplicitFileNotFound FilePath + | BadProjectRootDirNotFound FilePath + | BadProjectRootAbsoluteFileNotFound FilePath + | BadProjectRootDirFileNotFound FilePath FilePath + | BadProjectRootFileBroken FilePath + deriving (Show, Typeable, Eq) -#if MIN_VERSION_base(4,8,0) instance Exception BadProjectRoot where displayException = renderBadProjectRoot -#else -instance Exception BadProjectRoot -#endif renderBadProjectRoot :: BadProjectRoot -> String renderBadProjectRoot = \case - BadProjectRootExplicitFile projectFile -> + BadProjectRootExplicitFileNotFound projectFile -> "The given project file '" ++ projectFile ++ "' does not exist." - BadProjectRootDir dir -> + BadProjectRootDirNotFound dir -> "The given project directory '" <> dir <> "' does not exist." - BadProjectRootAbsoluteFile file -> + BadProjectRootAbsoluteFileNotFound file -> "The given project file '" <> file <> "' does not exist." - BadProjectRootDirFile dir file -> + BadProjectRootDirFileNotFound dir file -> "The given project directory/file combination '" <> dir file <> "' does not exist." + BadProjectRootFileBroken file -> + "The given project file '" <> file <> "' is broken. Is it a broken symbolic link?" +-- | State of the project file, encodes if the file can be used +data ProjectRootUsability + = -- | The file is present and can be used + ProjectRootUsabilityPresentAndUsable + | -- | The file is present but can't be used (e.g. broken symlink) + ProjectRootUsabilityPresentAndUnusable + | -- | The file is not present + ProjectRootUsabilityNotPresent + deriving (Eq, Show) + withGlobalConfig :: Verbosity -- ^ verbosity @@ -819,21 +890,11 @@ -- | Exception thrown by 'findProjectPackages'. data BadPackageLocations = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] -#if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) -#else - deriving (Typeable) -instance Show BadPackageLocations where - show = renderBadPackageLocations -#endif - -#if MIN_VERSION_base(4,8,0) instance Exception BadPackageLocations where displayException = renderBadPackageLocations -#else -instance Exception BadPackageLocations -#endif + -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc data BadPackageLocation @@ -1505,11 +1566,8 @@ . showChar ' ' . showsPrec 11 ws -instance Exception CabalFileParseError -#if MIN_VERSION_base(4,8,0) - where +instance Exception CabalFileParseError where displayException = renderCabalFileParseError -#endif renderCabalFileParseError :: CabalFileParseError -> String renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = @@ -1601,7 +1659,7 @@ localFileNameForRemoteTarball uri = mangleName uri ++ "-" - ++ showHex locationHash "" + ++ showHashValue locationHash where mangleName = truncateString 10 @@ -1611,15 +1669,15 @@ . dropTrailingPathSeparator . uriPath - locationHash :: Word - locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) + locationHash :: HashValue + locationHash = hashValue (toUTF8LBS (uriToString id uri "")) -- | The name to use for a local file or dir for a remote 'SourceRepo'. -- This is deterministic based on the source repo identity details, and -- intended to produce non-clashing file names for different repos. localFileNameForRemoteRepo :: SourceRepoList -> FilePath localFileNameForRemoteRepo SourceRepositoryPackage{srpType, srpLocation} = - mangleName srpLocation ++ "-" ++ showHex locationHash "" + mangleName srpLocation ++ "-" ++ showHashValue locationHash where mangleName = truncateString 10 @@ -1628,9 +1686,10 @@ . dropTrailingPathSeparator -- just the parts that make up the "identity" of the repo - locationHash :: Word + locationHash :: HashValue locationHash = - fromIntegral (Hashable.hash (show srpType, srpLocation)) + hashValue $ + LBS.fromChunks [toUTF8BS srpLocation, toUTF8BS (show srpType)] -- | Truncate a string, with a visual indication that it is truncated. truncateString :: Int -> String -> String @@ -1651,21 +1710,11 @@ data BadPerPackageCompilerPaths = BadPerPackageCompilerPaths [(PackageName, String)] -#if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) -#else - deriving (Typeable) -instance Show BadPerPackageCompilerPaths where - show = renderBadPerPackageCompilerPaths -#endif - -#if MIN_VERSION_base(4,8,0) instance Exception BadPerPackageCompilerPaths where displayException = renderBadPerPackageCompilerPaths -#else -instance Exception BadPerPackageCompilerPaths -#endif + -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String @@ -1705,3 +1754,9 @@ ] of [] -> return () ps -> throwIO (BadPerPackageCompilerPaths ps) + +-- | Filter out non-top-level project configs. +onlyTopLevelProvenance :: Set ProjectConfigProvenance -> Set ProjectConfigProvenance +onlyTopLevelProvenance = Set.filter $ \case + Implicit -> False + Explicit ps -> isTopLevelConfigPath ps 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,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -84,6 +85,7 @@ ( CompilerInfo (..) , DebugInfoLevel (..) , OptimisationLevel (..) + , interpretPackageDB ) import Distribution.Simple.InstallDirs (CopyDest (NoCopyDest)) import Distribution.Simple.LocalBuildInfo @@ -100,6 +102,7 @@ ) import Distribution.Simple.Setup ( BenchmarkFlags (..) + , CommonSetupFlags (..) , ConfigFlags (..) , DumpBuildInfo (DumpBuildInfo, NoDumpBuildInfo) , Flag (..) @@ -139,7 +142,9 @@ , toNubList ) +import Distribution.Client.HttpUtils import Distribution.Client.ParseUtils +import Distribution.Client.ReplFlags (multiReplOption) import Distribution.Deprecated.ParseUtils ( PError (..) , PWarning (..) @@ -159,6 +164,7 @@ , (+++) ) import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) import Distribution.Parsec (ParsecParser, parsecToken) import Distribution.Simple.Command ( CommandUI (commandOptions) @@ -171,6 +177,10 @@ import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint ) +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map @@ -185,11 +195,6 @@ ) import qualified Text.PrettyPrint as Disp -import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) - -import Distribution.Client.HttpUtils -import Distribution.Client.ReplFlags (multiReplOption) - ------------------------------------------------------------------ -- Handle extended project config files with conditionals and imports. -- @@ -504,6 +509,7 @@ , packageConfigHaddockInternal = packageConfigHaddockInternal pc , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc + , packageConfigHaddockUseUnicode = packageConfigHaddockUseUnicode pc } ) @@ -680,17 +686,25 @@ , globalStoreDir = projectConfigStoreDir } = globalFlags + projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ + ConfigFlags - { configDistPref = projectConfigDistDir + { configCommonFlags = commonFlags , configHcFlavor = projectConfigHcFlavor , configHcPath = projectConfigHcPath , configHcPkg = projectConfigHcPkg , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME configInstallDirs = projectConfigInstallDirs , -- configUserInstall = projectConfigUserInstall, - configPackageDBs = projectConfigPackageDBs + configPackageDBs = projectConfigPackageDBs_ } = configFlags + CommonSetupFlags + { setupDistPref = projectConfigAbsoluteDistDir + } = commonFlags + + projectConfigDistDir = fmap getSymbolicPath projectConfigAbsoluteDistDir + ConfigExFlags { configCabalVersion = projectConfigCabalVersion , configExConstraints = projectConfigConstraints @@ -758,6 +772,7 @@ , configFullyStaticExe = packageConfigFullyStaticExe , configProfExe = packageConfigProfExe , configProf = packageConfigProf + , configProfShared = packageConfigProfShared , configProfDetail = packageConfigProfDetail , configProfLibDetail = packageConfigProfLibDetail , configConfigureArgs = packageConfigConfigureArgs @@ -769,10 +784,6 @@ , configSplitObjs = packageConfigSplitObjs , configStripExes = packageConfigStripExes , configStripLibs = packageConfigStripLibs - , configExtraLibDirs = packageConfigExtraLibDirs - , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic - , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs - , configExtraIncludeDirs = packageConfigExtraIncludeDirs , configConfigurationsFlags = packageConfigFlagAssignment , configTests = packageConfigTests , configBenchmarks = packageConfigBenchmarks @@ -783,6 +794,10 @@ , configRelocatable = packageConfigRelocatable , configCoverageFor = _ } = configFlags + packageConfigExtraLibDirs = fmap getSymbolicPath $ configExtraLibDirs configFlags + packageConfigExtraLibDirsStatic = fmap getSymbolicPath $ configExtraLibDirsStatic configFlags + packageConfigExtraFrameworkDirs = fmap getSymbolicPath $ configExtraFrameworkDirs configFlags + packageConfigExtraIncludeDirs = fmap getSymbolicPath $ configExtraIncludeDirs configFlags packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) @@ -811,8 +826,9 @@ , haddockContents = packageConfigHaddockContents , haddockIndex = packageConfigHaddockIndex , haddockBaseUrl = packageConfigHaddockBaseUrl - , haddockLib = packageConfigHaddockLib + , haddockResourcesDir = packageConfigHaddockResourcesDir , haddockOutputDir = packageConfigHaddockOutputDir + , haddockUseUnicode = packageConfigHaddockUseUnicode } = haddockFlags TestFlags @@ -859,9 +875,13 @@ } = globalFlags ConfigFlags - { configVerbosity = projectConfigVerbosity + { configCommonFlags = commonFlags } = configFlags + CommonSetupFlags + { setupVerbosity = projectConfigVerbosity + } = commonFlags + InstallFlags { installDryRun = projectConfigDryRun , installOnlyDownload = projectConfigOnlyDownload @@ -951,11 +971,16 @@ , globalProgPathExtra = projectConfigProgPathExtra } + commonFlags = + mempty + { setupVerbosity = projectConfigVerbosity + , setupDistPref = fmap makeSymbolicPath $ projectConfigDistDir + } + configFlags = mempty - { configVerbosity = projectConfigVerbosity - , configDistPref = projectConfigDistDir - , configPackageDBs = projectConfigPackageDBs + { configCommonFlags = commonFlags + , configPackageDBs = fmap (fmap (fmap unsafeMakeSymbolicPath)) projectConfigPackageDBs , configInstallDirs = projectConfigInstallDirs } @@ -1033,9 +1058,12 @@ , legacyBenchmarkFlags = mempty } where + commonFlags = + mempty + configFlags = ConfigFlags - { configArgs = mempty + { configCommonFlags = commonFlags , configPrograms_ = mempty , configProgramPaths = mempty , configProgramArgs = mempty @@ -1052,6 +1080,7 @@ , configFullyStaticExe = mempty , configProfExe = mempty , configProf = mempty + , configProfShared = mempty , configProfDetail = mempty , configProfLibDetail = mempty , configConfigureArgs = mempty @@ -1060,9 +1089,6 @@ , configProgSuffix = mempty , configInstallDirs = projectConfigInstallDirs , configScratchDir = mempty - , configDistPref = mempty - , configCabalFilePath = mempty - , configVerbosity = mempty , configUserInstall = mempty -- projectConfigUserInstall, , configPackageDBs = mempty , configGHCiLib = mempty @@ -1093,6 +1119,7 @@ , configDumpBuildInfo = mempty , configAllowDependingOnPrivateLibs = mempty , configCoverageFor = mempty + , configIgnoreBuildTools = mempty } haddockFlags = @@ -1110,9 +1137,11 @@ , legacyBenchmarkFlags = benchmarkFlags } where + commonFlags = + mempty configFlags = ConfigFlags - { configArgs = mempty + { configCommonFlags = commonFlags , configPrograms_ = configPrograms_ mempty , configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths) , configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs) @@ -1129,6 +1158,7 @@ , configFullyStaticExe = packageConfigFullyStaticExe , configProfExe = packageConfigProfExe , configProf = packageConfigProf + , configProfShared = packageConfigProfShared , configProfDetail = packageConfigProfDetail , configProfLibDetail = packageConfigProfLibDetail , configConfigureArgs = packageConfigConfigureArgs @@ -1137,9 +1167,6 @@ , configProgSuffix = packageConfigProgSuffix , configInstallDirs = mempty , configScratchDir = mempty - , configDistPref = mempty - , configCabalFilePath = mempty - , configVerbosity = mempty , configUserInstall = mempty , configPackageDBs = mempty , configGHCiLib = packageConfigGHCiLib @@ -1147,13 +1174,13 @@ , configSplitObjs = packageConfigSplitObjs , configStripExes = packageConfigStripExes , configStripLibs = packageConfigStripLibs - , configExtraLibDirs = packageConfigExtraLibDirs - , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic - , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs + , configExtraLibDirs = fmap makeSymbolicPath $ packageConfigExtraLibDirs + , configExtraLibDirsStatic = fmap makeSymbolicPath $ packageConfigExtraLibDirsStatic + , configExtraFrameworkDirs = fmap makeSymbolicPath $ packageConfigExtraFrameworkDirs , configConstraints = mempty , configDependencies = mempty , configPromisedDependencies = mempty - , configExtraIncludeDirs = packageConfigExtraIncludeDirs + , configExtraIncludeDirs = fmap makeSymbolicPath $ packageConfigExtraIncludeDirs , configIPID = mempty , configCID = mempty , configDeterministic = mempty @@ -1170,6 +1197,7 @@ , configDumpBuildInfo = packageConfigDumpBuildInfo , configAllowDependingOnPrivateLibs = mempty , configCoverageFor = mempty + , configIgnoreBuildTools = mempty } installFlags = @@ -1180,7 +1208,8 @@ haddockFlags = HaddockFlags - { haddockProgramPaths = mempty + { haddockCommonFlags = commonFlags + , haddockProgramPaths = mempty , haddockProgramArgs = mempty , haddockHoogle = packageConfigHaddockHoogle , haddockHtml = packageConfigHaddockHtml @@ -1196,21 +1225,17 @@ , haddockQuickJump = packageConfigHaddockQuickJump , haddockHscolourCss = packageConfigHaddockHscolourCss , haddockContents = packageConfigHaddockContents - , haddockDistPref = mempty , haddockKeepTempFiles = mempty - , haddockVerbosity = mempty - , haddockCabalFilePath = mempty , haddockIndex = packageConfigHaddockIndex , haddockBaseUrl = packageConfigHaddockBaseUrl - , haddockLib = packageConfigHaddockLib + , haddockResourcesDir = packageConfigHaddockResourcesDir , haddockOutputDir = packageConfigHaddockOutputDir - , haddockArgs = mempty + , haddockUseUnicode = packageConfigHaddockUseUnicode } testFlags = TestFlags - { testDistPref = mempty - , testVerbosity = mempty + { testCommonFlags = commonFlags , testHumanLog = packageConfigTestHumanLog , testMachineLog = packageConfigTestMachineLog , testShowDetails = packageConfigTestShowDetails @@ -1222,8 +1247,7 @@ benchmarkFlags = BenchmarkFlags - { benchmarkDistPref = mempty - , benchmarkVerbosity = mempty + { benchmarkCommonFlags = commonFlags , benchmarkOptions = packageConfigBenchmarkOptions } @@ -1485,26 +1509,26 @@ "extra-include-dirs" showTokenQ parseTokenQ - configExtraIncludeDirs - (\v conf -> conf{configExtraIncludeDirs = v}) + (fmap getSymbolicPath . configExtraIncludeDirs) + (\v conf -> conf{configExtraIncludeDirs = fmap makeSymbolicPath v}) , newLineListField "extra-lib-dirs" showTokenQ parseTokenQ - configExtraLibDirs - (\v conf -> conf{configExtraLibDirs = v}) + (fmap getSymbolicPath . configExtraLibDirs) + (\v conf -> conf{configExtraLibDirs = fmap makeSymbolicPath v}) , newLineListField "extra-lib-dirs-static" showTokenQ parseTokenQ - configExtraLibDirsStatic - (\v conf -> conf{configExtraLibDirsStatic = v}) + (fmap getSymbolicPath . configExtraLibDirsStatic) + (\v conf -> conf{configExtraLibDirsStatic = fmap makeSymbolicPath v}) , newLineListField "extra-framework-dirs" showTokenQ parseTokenQ - configExtraFrameworkDirs - (\v conf -> conf{configExtraFrameworkDirs = v}) + (fmap getSymbolicPath . configExtraFrameworkDirs) + (\v conf -> conf{configExtraFrameworkDirs = fmap makeSymbolicPath v}) , newLineListField "extra-prog-path" showTokenQ @@ -1532,11 +1556,13 @@ , "program-suffix" , "library-vanilla" , "library-profiling" + , "library-vanilla" , "shared" , "static" , "executable-dynamic" , "executable-static" , "profiling" + , "profiling-shared" , "executable-profiling" , "profiling-detail" , "library-profiling-detail" @@ -1606,8 +1632,9 @@ , "index-location" , "keep-temp-files" , "base-url" - , "lib" + , "resources-dir" , "output-dir" + , "use-unicode" ] . commandOptionsToFields ) 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 @@ -69,7 +69,7 @@ , CompilerFlavor , DebugInfoLevel (..) , OptimisationLevel (..) - , PackageDB + , PackageDBCWD , ProfDetailLevel ) import Distribution.Simple.InstallDirs @@ -198,7 +198,7 @@ -- projectConfigUserInstall :: Flag Bool, projectConfigInstallDirs :: InstallDirs (Flag PathTemplate) - , projectConfigPackageDBs :: [Maybe PackageDB] + , projectConfigPackageDBs :: [Maybe PackageDBCWD] , -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. @@ -265,6 +265,7 @@ , packageConfigFullyStaticExe :: Flag Bool , packageConfigProf :: Flag Bool -- TODO: [code cleanup] sort out , packageConfigProfLib :: Flag Bool -- this duplication + , packageConfigProfShared :: Flag Bool , packageConfigProfExe :: Flag Bool -- and consistency , packageConfigProfDetail :: Flag ProfDetailLevel , packageConfigProfLibDetail :: Flag ProfDetailLevel @@ -305,8 +306,9 @@ , packageConfigHaddockContents :: Flag PathTemplate -- TODO: [required eventually] use this , packageConfigHaddockIndex :: Flag PathTemplate -- TODO: [required eventually] use this , packageConfigHaddockBaseUrl :: Flag String -- TODO: [required eventually] use this - , packageConfigHaddockLib :: Flag String -- TODO: [required eventually] use this + , packageConfigHaddockResourcesDir :: Flag String -- TODO: [required eventually] use this , packageConfigHaddockOutputDir :: Flag FilePath -- TODO: [required eventually] use this + , packageConfigHaddockUseUnicode :: Flag Bool -- TODO: [required eventually] use this , packageConfigHaddockForHackage :: Flag HaddockTarget , -- Test options packageConfigTestHumanLog :: Flag PathTemplate 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 @@ -216,6 +216,7 @@ import Distribution.Utils.NubList ( fromNubList ) +import Distribution.Utils.Path (makeSymbolicPath) import Distribution.Verbosity import Distribution.Version ( mkVersion @@ -1042,13 +1043,20 @@ showConfigureFlags :: ElaboratedConfiguredPackage -> String showConfigureFlags elab = - let fullConfigureFlags = - setupHsConfigureFlags - elaboratedPlan - (ReadyPackage elab) - elaboratedShared + let commonFlags = + setupHsCommonFlags verbosity - "$builddir" + Nothing -- omit working directory + (makeSymbolicPath "$builddir") + fullConfigureFlags = + runIdentity $ + ( setupHsConfigureFlags + (\_ -> return (error "unused")) + elaboratedPlan + (ReadyPackage elab) + elaboratedShared + commonFlags + ) -- \| Given a default value @x@ for a flag, nub @Flag x@ -- into @NoFlag@. This gives us a tidier command line -- rendering. @@ -1056,7 +1064,7 @@ nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag nubFlag _ f = f - (tryLibProfiling, tryExeProfiling) = + (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling fullConfigureFlags partialConfigureFlags = @@ -1067,7 +1075,8 @@ nubFlag tryExeProfiling (configProfExe fullConfigureFlags) , configProfLib = nubFlag tryLibProfiling (configProfLib fullConfigureFlags) - -- Maybe there are more we can add + , configProfShared = + nubFlag tryLibProfilingShared (configProfShared fullConfigureFlags) } in -- Not necessary to "escape" it, it's just for user output unwords . ("" :) $ @@ -1406,11 +1415,7 @@ " The build process terminated with exit code " ++ show n _ -> " The exception was:\n " -#if MIN_VERSION_base(4,8,0) ++ displayException e -#else - ++ show e -#endif buildFailureException :: BuildFailureReason -> Maybe SomeException buildFailureException reason = 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,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -39,7 +40,6 @@ import qualified Distribution.Compat.Binary as Binary import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Graph as Graph -import Distribution.Compiler (CompilerFlavor (GHC, GHCJS)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package import qualified Distribution.PackageDescription as PD @@ -49,15 +49,6 @@ , exeExtension ) import Distribution.Simple.Compiler - ( Compiler - , CompilerId (..) - , PackageDB (..) - , PackageDBStack - , compilerFlavor - , compilerId - , compilerVersion - , showCompilerId - ) import Distribution.Simple.GHC ( GhcEnvironmentFileEntry (..) , GhcImplInfo (supportsPkgEnvFiles) @@ -70,6 +61,10 @@ import Distribution.Types.Version ( mkVersion ) +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import Distribution.Verbosity import Distribution.Client.Compat.Prelude @@ -225,7 +220,7 @@ | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] = "build-info" J..= J.Null | otherwise = - "build-info" J..= J.String (buildInfoPref dist_dir) + "build-info" J..= J.String (getSymbolicPath $ buildInfoPref $ makeSymbolicPath dist_dir) packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value packageLocationToJ pkgloc = @@ -866,7 +861,7 @@ :: FilePath -> ElaboratedInstallPlan -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry] + -> [GhcEnvironmentFileEntry FilePath] renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan @@ -972,7 +967,7 @@ elabRequiresRegistration pkg && installedUnitId pkg `Set.member` packagesProbablyUpToDate -selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack +selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = -- If we have any inplace packages then their package db stack is the -- one we should use since it'll include the store + the local db but @@ -982,7 +977,7 @@ ([], pkgs) -> checkSamePackageDBs pkgs (pkgs, _) -> checkSamePackageDBs pkgs where - checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack + checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStackCWD checkSamePackageDBs pkgs = case ordNub (map elabBuildPackageDBStack pkgs) of [packageDbs] -> packageDbs @@ -1014,14 +1009,14 @@ InstallPlan.PreExisting _ -> Nothing ] -relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack +relativePackageDBPaths :: FilePath -> PackageDBStackCWD -> PackageDBStackCWD relativePackageDBPaths relroot = map (relativePackageDBPath relroot) -relativePackageDBPath :: FilePath -> PackageDB -> PackageDB +relativePackageDBPath :: FilePath -> PackageDBCWD -> PackageDBCWD relativePackageDBPath relroot pkgdb = case pkgdb of GlobalPackageDB -> GlobalPackageDB UserPackageDB -> UserPackageDB SpecificPackageDB path -> SpecificPackageDB relpath where - relpath = makeRelative relroot path + relpath = makeRelative (normalise relroot) path 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} @@ -74,6 +75,7 @@ -- * Setup.hs CLI flags for building , setupHsScriptOptions + , setupHsCommonFlags , setupHsConfigureFlags , setupHsConfigureArgs , setupHsBuildFlags @@ -136,6 +138,10 @@ import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum import Distribution.Utils.NubList +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) import qualified Hackage.Security.Client as Sec @@ -159,6 +165,8 @@ , componentName , pkgComponents ) + +import Distribution.Simple.BuildWay import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program import Distribution.Simple.Program.Db @@ -184,6 +192,7 @@ import Distribution.Backpack.ModuleShape import Distribution.Simple.Utils +import Distribution.Verbosity import Distribution.Version import qualified Distribution.InstalledPackageInfo as IPI @@ -386,13 +395,13 @@ localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) - sequence_ - [ do - info verbosity . render . vcat $ - text "this build was affected by the following (project) config files:" - : [text "-" <+> docProjectConfigPath path] - | Explicit path <- Set.toList $ projectConfigProvenance projectConfig - ] + let configfiles = + [ text "-" <+> docProjectConfigPath path + | Explicit path <- Set.toList . (if verbosity >= verbose then id else onlyTopLevelProvenance) $ projectConfigProvenance projectConfig + ] + unless (null configfiles) $ + notice (verboseStderr verbosity) . render . vcat $ + text "Configuration is affected by the following files:" : configfiles return (projectConfig <> cliConfig, localPackages) where @@ -459,7 +468,7 @@ , packageConfigProgramPathExtra } } = do - let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler" + let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" progsearchpath <- liftIO $ getSystemSearchPath rerunIfChanged @@ -474,9 +483,10 @@ ) $ do liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - progdb <- liftIO $ prependProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) defaultProgramDb + let extraPath = fromNubList packageConfigProgramPathExtra + progdb <- liftIO $ prependProgramSearchPath verbosity extraPath [] defaultProgramDb let progdb' = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) progdb - result@(_, _, progdb'') <- + (comp, plat, progdb'') <- liftIO $ Cabal.configCompilerEx hcFlavor @@ -493,7 +503,12 @@ -- programs it cares about, and those are the ones we monitor here. monitorFiles (programsMonitorFiles progdb'') - return result + -- Configure the unconfigured programs in the program database, + -- as we can't serialise unconfigured programs. + -- See also #2241 and #9840. + finalProgDb <- liftIO $ configureAllKnownPrograms verbosity progdb'' + + return (comp, plat, finalProgDb) where hcFlavor = flagToMaybe projectConfigHcFlavor hcPath = flagToMaybe projectConfigHcPath @@ -650,7 +665,7 @@ -> (Compiler, Platform, ProgramDb) -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex - -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared @@ -710,7 +725,7 @@ dieWithException verbosity $ PhaseRunSolverErr msg Right plan -> return (plan, pkgConfigDB, tis, ar) where - corePackageDbs :: [PackageDB] + corePackageDbs :: PackageDBStackCWD corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared) @@ -762,7 +777,7 @@ phaseElaboratePlan :: ProjectConfig -> (Compiler, Platform, ProgramDb) - -> PkgConfigDb + -> Maybe PkgConfigDb -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Rebuild @@ -941,7 +956,7 @@ -> Compiler -> ProgramDb -> Platform - -> PackageDBStack + -> PackageDBStackCWD -> Rebuild InstalledPackageIndex getInstalledPackages verbosity compiler progdb platform packagedbs = do monitorFiles . map monitorFileOrDirectory @@ -949,7 +964,8 @@ ( IndexUtils.getInstalledPackagesMonitorFiles verbosity compiler - packagedbs + Nothing -- use ambient working directory + (coercePackageDBStack packagedbs) progdb platform ) @@ -995,7 +1011,7 @@ $ repos return sourcePkgDbWithTIS -getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb +getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild (Maybe PkgConfigDb) getPkgConfigDb verbosity progdb = do dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb -- Just monitor the dirs so we'll notice new .pc files. @@ -1195,7 +1211,7 @@ -> SolverSettings -> InstalledPackageIndex -> SourcePackageDb - -> PkgConfigDb + -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Map PackageName (Map OptionalStanza Bool) -> Progress String String SolverInstallPlan @@ -1518,7 +1534,7 @@ -> Platform -> Compiler -> ProgramDb - -> PkgConfigDb + -> Maybe PkgConfigDb -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan @@ -1614,13 +1630,18 @@ (map fst src_comps) let whyNotPerComp = why_not_per_component src_comps case NE.nonEmpty whyNotPerComp of - Nothing -> return comps + Nothing -> do + elaborationWarnings + return comps Just notPerCompReasons -> do checkPerPackageOk comps notPerCompReasons - return - [ elaborateSolverToPackage notPerCompReasons spkg g $ - comps ++ maybeToList setupComponent - ] + pkgComp <- + elaborateSolverToPackage + notPerCompReasons + spkg + g + (comps ++ maybeToList setupComponent) + return [pkgComp] Left cns -> dieProgress $ hang @@ -1628,6 +1649,7 @@ 4 (vcat (map (text . componentNameStanza) cns)) where + bt = PD.buildType (elabPkgDescription elab0) -- You are eligible to per-component build if this list is empty why_not_per_component g = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag @@ -1643,11 +1665,12 @@ -- type, and teach all of the code paths how to handle it. -- Once you've implemented this, swap it for the code below. cuz_buildtype = - case PD.buildType (elabPkgDescription elab0) of + case bt of PD.Configure -> [CuzBuildType CuzConfigureBuildType] PD.Custom -> [CuzBuildType CuzCustomBuildType] + PD.Hooks -> [CuzBuildType CuzHooksBuildType] PD.Make -> [CuzBuildType CuzMakeBuildType] - _ -> [] + PD.Simple -> [] -- 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 @@ -1681,7 +1704,7 @@ <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) -- TODO: Maybe exclude Backpack too - elab0 = elaborateSolverToCommon spkg + (elab0, elaborationWarnings) = elaborateSolverToCommon spkg pkgid = elabPkgSourceId elab0 pd = elabPkgDescription elab0 @@ -1691,7 +1714,7 @@ -- have to add dependencies on this from all other components setupComponent :: Maybe ElaboratedConfiguredPackage setupComponent - | PD.buildType (elabPkgDescription elab0) == PD.Custom = + | bt `elem` [PD.Custom, PD.Hooks] = Just elab0 { elabModuleShape = emptyModuleShape @@ -1915,7 +1938,7 @@ ++ " from " ++ prettyShow (elabPkgSourceId elab0) ) - (pkgConfigDbPkgVersion pkgConfigDB pn) + (pkgConfigDB >>= \db -> pkgConfigDbPkgVersion db pn) ) | PkgconfigDependency pn _ <- PD.pkgconfigDepends @@ -1977,7 +2000,7 @@ -> SolverPackage UnresolvedPkgLoc -> ComponentsGraph -> [ElaboratedConfiguredPackage] - -> ElaboratedConfiguredPackage + -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent pkg@( SolverPackage @@ -1988,13 +2011,14 @@ _exe_deps0 ) compGraph - comps = + comps = do -- Knot tying: the final elab includes the -- pkgInstalledId, which is calculated by hashing many -- of the other fields of the elaboratedPackage. - elab + elaborationWarnings + return elab where - elab0@ElaboratedConfiguredPackage{..} = + (elab0@ElaboratedConfiguredPackage{..}, elaborationWarnings) = elaborateSolverToCommon pkg elab1 = @@ -2080,7 +2104,7 @@ elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage + -> (ElaboratedConfiguredPackage, LogProgress ()) elaborateSolverToCommon pkg@( SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) @@ -2089,7 +2113,7 @@ deps0 _exe_deps0 ) = - elaboratedPackage + (elaboratedPackage, wayWarnings pkgid) where elaboratedPackage = ElaboratedConfiguredPackage{..} @@ -2157,6 +2181,13 @@ elabBuildHaddocks = perPkgOptionFlag pkgid False packageConfigDocumentation + -- `documentation: true` should imply `-haddock` for GHC + addHaddockIfDocumentationEnabled :: ConfiguredProgram -> ConfiguredProgram + addHaddockIfDocumentationEnabled cp@ConfiguredProgram{..} = + if programId == "ghc" && elabBuildHaddocks + then cp{programOverrideArgs = "-haddock" : programOverrideArgs} + else cp + elabPkgSourceLocation = srcloc elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes elabLocalToProject = isLocalToProject pkg @@ -2190,13 +2221,14 @@ elabBuildOptions = LBC.BuildOptions { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary , withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib , withDynExe = perPkgOptionFlag pkgid False packageConfigDynExe , withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe , withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still , withProfExe = perPkgOptionFlag pkgid False packageConfigProf - , withProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary + , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization @@ -2236,7 +2268,7 @@ Map.fromList [ (programId prog, args) | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog + , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog , not (null args) ] <> perPkgOptionMapMappend pkgid packageConfigProgramArgs @@ -2265,8 +2297,9 @@ elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl - elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib + elabHaddockResourcesDir = perPkgOptionMaybe pkgid packageConfigHaddockResourcesDir elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir + elabHaddockUseUnicode = perPkgOptionFlag pkgid False packageConfigHaddockUseUnicode elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog @@ -2355,35 +2388,112 @@ pkgsUseSharedLibrary :: Set PackageId pkgsUseSharedLibrary = packagesWithLibDepsDownwardClosedProperty needsSharedLib + + needsSharedLib pkgid = + fromMaybe + compilerShouldUseSharedLibByDefault + -- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that. + ( case pkgSharedLib of + Just v -> Just v + Nothing -> case pkgDynExe of + -- case 2: If --enable-executable-dynamic is passed then turn on + -- shared library generation. + Just True -> + -- Case 3: If --enable-profiling is passed, then we are going to + -- build profiled dynamic, so no need for shared libraries. + case pkgProf of + Just True -> if canBuildProfilingSharedLibs then Nothing else Just True + _ -> Just True + -- But don't necessarily turn off shared library generation if + -- --disable-executable-dynamic is passed. The shared objects might + -- be needed for something different. + _ -> Nothing + ) where - needsSharedLib pkg = - fromMaybe - compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + pkgProf = perPkgOptionMaybe pkgid packageConfigProf -- TODO: [code cleanup] move this into the Cabal lib. It's currently open -- coded in Distribution.Simple.Configure, but should be made a proper -- function of the Compiler or CompilerInfo. compilerShouldUseSharedLibByDefault = case compilerFlavor compiler of - GHC -> GHC.isDynamic compiler + GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs GHCJS -> GHCJS.isDynamic compiler _ -> False + compilerShouldUseProfilingLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs + _ -> False + + compilerShouldUseProfilingSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs + _ -> False + + -- Returns False if we definitely can't build shared libs + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + -- If we don't know for certain, just assume we can + -- which matches behaviour in previous cabal releases + Nothing -> True + + canBuildSharedLibs = canBuildWayLibs dynamicSupported + canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported + canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported + + wayWarnings pkg = do + when + (needsProfilingLib pkg && not canBuildProfilingLibs) + (warnProgress (text "Compiler does not support building p libraries, profiling is disabled")) + when + (needsSharedLib pkg && not canBuildSharedLibs) + (warnProgress (text "Compiler does not support building dyn libraries, dynamic libraries are disabled")) + when + (needsProfilingLibShared pkg && not canBuildProfilingSharedLibs) + (warnProgress (text "Compiler does not support building p_dyn libraries, profiling dynamic libraries are disabled.")) + pkgsUseProfilingLibrary :: Set PackageId pkgsUseProfilingLibrary = packagesWithLibDepsDownwardClosedProperty needsProfilingLib + + needsProfilingLib pkg = + fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag) where - needsProfilingLib pkg = - fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + + pkgsUseProfilingLibraryShared :: Set PackageId + pkgsUseProfilingLibraryShared = + packagesWithLibDepsDownwardClosedProperty needsProfilingLibShared + + needsProfilingLibShared pkg = + fromMaybe + compilerShouldUseProfilingSharedLibByDefault + -- case 1: If --enable-profiling-shared is passed explicitly, honour that + ( case profLibSharedFlag of + Just v -> Just v + Nothing -> case pkgDynExe of + Just True -> + case pkgProf of + -- case 2: --enable-executable-dynamic + --enable-profiling + -- turn on shared profiling libraries + Just True -> if canBuildProfilingSharedLibs then Just True else Nothing + _ -> Nothing + -- But don't necessarily turn off shared library generation is + -- --disable-executable-dynamic is passed. The shared objects might + -- be needed for something different. + _ -> Nothing + ) + where + pkgid = packageId pkg + profLibSharedFlag = perPkgOptionMaybe pkgid packageConfigProfShared + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + pkgProf = perPkgOptionMaybe pkgid packageConfigProf + -- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe libDepGraph = @@ -2400,7 +2510,7 @@ libDepGraph [ Graph.nodeKey pkg | pkg <- SolverInstallPlan.toList solverPlan - , property pkg -- just the packages that satisfy the property + , property (packageId pkg) -- just the packages that satisfy the property -- TODO: [nice to have] this does not check the config consistency, -- e.g. a package explicitly turning off profiling, but something -- depending on it that needs profiling. This really needs a separate @@ -3657,8 +3767,8 @@ -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> DistDirLayout - -> FilePath - -> FilePath + -> SymbolicPath CWD (Dir Pkg) + -> SymbolicPath Pkg (Dir Dist) -> Bool -> Lock -> SetupScriptOptions @@ -3675,7 +3785,14 @@ cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion - , useCabalSpecVersion = Just elabSetupScriptCliVersion + , useCabalSpecVersion = + if PD.buildType elabPkgDescription == PD.Hooks + then -- NB: we don't want to commit to a Cabal version here: + -- - all that should matter for Hooks build-type is the + -- version of Cabal-hooks, not of Cabal, + -- - if we commit to a Cabal version, the logic in + Nothing + else Just elabSetupScriptCliVersion , useCompiler = Just pkgConfigCompiler , usePlatform = Just pkgConfigPlatform , usePackageDB = elabSetupPackageDBStack @@ -3793,24 +3910,31 @@ -- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags - setupHsConfigureFlags - :: ElaboratedInstallPlan + :: Monad m + => (FilePath -> m (SymbolicPath Pkg (Dir PkgDB))) + -- ^ How to transform a path which is relative to cabal-install cwd to one which + -- is relative to the route of the package about to be compiled. The simplest way + -- to do this is to convert the potentially relative path into an absolute path. + -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags + -> Cabal.CommonSetupFlags + -> m Cabal.ConfigFlags setupHsConfigureFlags + mkSymbolicPath plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) sharedConfig@ElaboratedSharedConfig{..} - verbosity - builddir = - sanityCheckElaboratedConfiguredPackage - sharedConfig - elab - (Cabal.ConfigFlags{..}) + configCommonFlags = do + -- explicitly clear, then our package db stack + -- TODO: [required eventually] have to do this differently for older Cabal versions + configPackageDBs <- (traverse . traverse . traverse) mkSymbolicPath (Nothing : map Just elabBuildPackageDBStack) + return $ + sanityCheckElaboratedConfiguredPackage + sharedConfig + elab + Cabal.ConfigFlags{..} where Cabal.ConfigFlags { configVanillaLib @@ -3821,6 +3945,7 @@ , configGHCiLib , -- , configProfExe -- overridden configProfLib + , configProfShared , -- , configProf -- overridden configProfDetail , configProfLibDetail @@ -3837,11 +3962,6 @@ configProfExe = mempty configProf = toFlag $ LBC.withProfExe elabBuildOptions - configArgs = mempty -- unused, passed via args - configDistPref = toFlag builddir - configCabalFilePath = mempty - configVerbosity = toFlag verbosity - configInstantiateWith = Map.toList elabInstantiatedWith configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese @@ -3882,10 +4002,10 @@ configConfigurationsFlags = elabFlagAssignment configConfigureArgs = elabConfigureScriptArgs - configExtraLibDirs = elabExtraLibDirs - configExtraLibDirsStatic = elabExtraLibDirsStatic - configExtraFrameworkDirs = elabExtraFrameworkDirs - configExtraIncludeDirs = elabExtraIncludeDirs + 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 @@ -3907,7 +4027,7 @@ ] configPromisedDependencies = - [ cidToGivenComponent cid + [ cidToPromisedComponent cid | (cid, is_internal) <- elabLibDependencies elab , is_internal ] @@ -3920,10 +4040,6 @@ ] ElabComponent _ -> [] - -- explicitly clear, then our package db stack - -- TODO: [required eventually] have to do this differently for older Cabal versions - configPackageDBs = Nothing : map Just elabBuildPackageDBStack - configTests = case elabPkgOrComp of ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty @@ -3938,6 +4054,7 @@ configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + configIgnoreBuildTools = mempty cidToGivenComponent :: ConfiguredId -> GivenComponent cidToGivenComponent (ConfiguredId srcid mb_cn cid) = GivenComponent (packageName srcid) ln cid @@ -3947,8 +4064,17 @@ Just _ -> error "non-library dependency" Nothing -> LMainLibName - configCoverageFor = determineCoverageFor elabPkgSourceId plan + configCoverageFor = determineCoverageFor elab plan + cidToPromisedComponent :: ConfiguredId -> PromisedComponent + cidToPromisedComponent (ConfiguredId srcid mb_cn cid) = + PromisedComponent srcid ln cid + where + ln = case mb_cn of + Just (CLibName lname) -> lname + Just _ -> error "non-library dependency" + Nothing -> LMainLibName + setupHsConfigureArgs :: ElaboratedConfiguredPackage -> [String] @@ -3961,27 +4087,37 @@ (error "setupHsConfigureArgs: trying to configure setup") (compComponentName comp) +setupHsCommonFlags + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> Cabal.CommonSetupFlags +setupHsCommonFlags verbosity mbWorkDir builddir = + Cabal.CommonSetupFlags + { setupDistPref = toFlag builddir + , setupVerbosity = toFlag verbosity + , setupCabalFilePath = mempty + , setupWorkingDir = maybeToFlag mbWorkDir + , setupTargets = [] + } + setupHsBuildFlags :: Flag String -> ElaboratedConfiguredPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath + -> Cabal.CommonSetupFlags -> Cabal.BuildFlags -setupHsBuildFlags par_strat elab _ verbosity builddir = +setupHsBuildFlags par_strat elab _ common = Cabal.BuildFlags - { buildProgramPaths = mempty -- unused, set at configure time + { buildCommonFlags = common + , buildProgramPaths = mempty -- unused, set at configure time , buildProgramArgs = mempty -- unused, set at configure time - , buildVerbosity = toFlag verbosity - , buildDistPref = toFlag builddir , buildNumJobs = mempty -- TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), , buildUseSemaphore = if elabSetupScriptCliVersion elab >= mkVersion [3, 11, 0, 0] then -- Cabal 3.11 is the first version that supports parallelism semaphores par_strat else mempty - , buildArgs = mempty -- unused, passed via args not flags - , buildCabalFilePath = mempty } setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] @@ -3996,13 +4132,11 @@ setupHsTestFlags :: ElaboratedConfiguredPackage - -> Verbosity - -> FilePath + -> Cabal.CommonSetupFlags -> Cabal.TestFlags -setupHsTestFlags (ElaboratedConfiguredPackage{..}) verbosity builddir = +setupHsTestFlags (ElaboratedConfiguredPackage{..}) common = Cabal.TestFlags - { testDistPref = toFlag builddir - , testVerbosity = toFlag verbosity + { testCommonFlags = common , testMachineLog = maybe mempty toFlag elabTestMachineLog , testHumanLog = maybe mempty toFlag elabTestHumanLog , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails @@ -4020,13 +4154,11 @@ setupHsBenchFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath + -> Cabal.CommonSetupFlags -> Cabal.BenchmarkFlags -setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ common = Cabal.BenchmarkFlags - { benchmarkDistPref = toFlag builddir - , benchmarkVerbosity = toFlag verbosity + { benchmarkCommonFlags = common , benchmarkOptions = elabBenchmarkOptions } @@ -4037,15 +4169,13 @@ setupHsReplFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath + -> Cabal.CommonSetupFlags -> Cabal.ReplFlags -setupHsReplFlags _ sharedConfig verbosity builddir = +setupHsReplFlags _ sharedConfig common = Cabal.ReplFlags - { replProgramPaths = mempty -- unused, set at configure time + { replCommonFlags = common + , replProgramPaths = mempty -- unused, set at configure time , replProgramArgs = mempty -- unused, set at configure time - , replVerbosity = toFlag verbosity - , replDistPref = toFlag builddir , replReload = mempty -- only used as callback from repl , replReplOptions = pkgConfigReplOptions sharedConfig -- runtime override for repl flags } @@ -4057,88 +4187,81 @@ setupHsCopyFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath + -> Cabal.CommonSetupFlags -> FilePath -> Cabal.CopyFlags -setupHsCopyFlags _ _ verbosity builddir destdir = +setupHsCopyFlags _ _ common destdir = Cabal.CopyFlags - { copyArgs = [] -- TODO: could use this to only copy what we enabled + { copyCommonFlags = common , copyDest = toFlag (InstallDirs.CopyTo destdir) - , copyDistPref = toFlag builddir - , copyVerbosity = toFlag verbosity - , copyCabalFilePath = mempty } setupHsRegisterFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath + -> Cabal.CommonSetupFlags -> FilePath -> Cabal.RegisterFlags setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ - verbosity - builddir + common pkgConfFile = Cabal.RegisterFlags - { regPackageDB = mempty -- misfeature + { registerCommonFlags = common + , regPackageDB = mempty -- misfeature , regGenScript = mempty -- never use - , regGenPkgConf = toFlag (Just pkgConfFile) + , regGenPkgConf = toFlag (Just (makeSymbolicPath pkgConfFile)) , regInPlace = case elabBuildStyle of BuildInplaceOnly{} -> toFlag True BuildAndInstall -> toFlag False , regPrintId = mempty -- never use - , regDistPref = toFlag builddir - , regArgs = [] - , regVerbosity = toFlag verbosity - , regCabalFilePath = mempty } setupHsHaddockFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig - -> Verbosity - -> FilePath + -> BuildTimeSettings + -> Cabal.CommonSetupFlags -> Cabal.HaddockFlags -setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) (ElaboratedSharedConfig{..}) verbosity builddir = - Cabal.HaddockFlags - { haddockProgramPaths = - case lookupProgram haddockProgram pkgConfigCompilerProgs of - Nothing -> mempty - Just prg -> - [ - ( programName haddockProgram - , locationPath (programLocation prg) - ) - ] - , haddockProgramArgs = mempty -- unused, set at configure time - , haddockHoogle = toFlag elabHaddockHoogle - , haddockHtml = toFlag elabHaddockHtml - , haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation - , haddockForHackage = toFlag elabHaddockForHackage - , haddockForeignLibs = toFlag elabHaddockForeignLibs - , haddockExecutables = toFlag elabHaddockExecutables - , haddockTestSuites = toFlag elabHaddockTestSuites - , haddockBenchmarks = toFlag elabHaddockBenchmarks - , haddockInternal = toFlag elabHaddockInternal - , haddockCss = maybe mempty toFlag elabHaddockCss - , haddockLinkedSource = toFlag elabHaddockLinkedSource - , haddockQuickJump = toFlag elabHaddockQuickJump - , haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss - , haddockContents = maybe mempty toFlag elabHaddockContents - , haddockDistPref = toFlag builddir - , haddockKeepTempFiles = mempty -- TODO: from build settings - , haddockVerbosity = toFlag verbosity - , haddockCabalFilePath = mempty - , haddockIndex = maybe mempty toFlag elabHaddockIndex - , haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl - , haddockLib = maybe mempty toFlag elabHaddockLib - , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir - , haddockArgs = mempty - } +setupHsHaddockFlags + (ElaboratedConfiguredPackage{..}) + (ElaboratedSharedConfig{..}) + (BuildTimeSettings{buildSettingKeepTempFiles = keepTmpFiles}) + common = + Cabal.HaddockFlags + { haddockCommonFlags = common + , haddockProgramPaths = + case lookupProgram haddockProgram pkgConfigCompilerProgs of + Nothing -> mempty + Just prg -> + [ + ( programName haddockProgram + , locationPath (programLocation prg) + ) + ] + , haddockProgramArgs = mempty -- unused, set at configure time + , haddockHoogle = toFlag elabHaddockHoogle + , haddockHtml = toFlag elabHaddockHtml + , haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation + , haddockForHackage = toFlag elabHaddockForHackage + , haddockForeignLibs = toFlag elabHaddockForeignLibs + , haddockExecutables = toFlag elabHaddockExecutables + , haddockTestSuites = toFlag elabHaddockTestSuites + , haddockBenchmarks = toFlag elabHaddockBenchmarks + , haddockInternal = toFlag elabHaddockInternal + , haddockCss = maybe mempty toFlag elabHaddockCss + , haddockLinkedSource = toFlag elabHaddockLinkedSource + , haddockQuickJump = toFlag elabHaddockQuickJump + , haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss + , haddockContents = maybe mempty toFlag elabHaddockContents + , haddockKeepTempFiles = toFlag keepTmpFiles + , haddockIndex = maybe mempty toFlag elabHaddockIndex + , haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl + , haddockResourcesDir = maybe mempty toFlag elabHaddockResourcesDir + , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir + , haddockUseUnicode = toFlag elabHaddockUseUnicode + } setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well @@ -4294,8 +4417,9 @@ , pkgHashHaddockContents = elabHaddockContents , pkgHashHaddockIndex = elabHaddockIndex , pkgHashHaddockBaseUrl = elabHaddockBaseUrl - , pkgHashHaddockLib = elabHaddockLib + , pkgHashHaddockResourcesDir = elabHaddockResourcesDir , pkgHashHaddockOutputDir = elabHaddockOutputDir + , pkgHashHaddockUseUnicode = elabHaddockUseUnicode } where ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg @@ -4360,13 +4484,14 @@ -- The list of non-pre-existing libraries without module holes, i.e. the -- main library and sub-libraries components of all the local packages in --- the project that do not require instantiations or are instantiations. +-- the project that are dependencies of the components being built and that do +-- not require instantiations or are instantiations. determineCoverageFor - :: PackageId - -- ^ The 'PackageId' of the package or component being configured + :: ElaboratedConfiguredPackage + -- ^ The package or component being configured -> ElaboratedInstallPlan -> Flag [UnitId] -determineCoverageFor configuredPkgSourceId plan = +determineCoverageFor configuredPkg plan = Flag $ mapMaybe ( \case @@ -4379,15 +4504,18 @@ $ Graph.toList $ InstallPlan.toGraph plan where - shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId, elabLocalToProject} = + libDeps = elabLibDependencies configuredPkg + shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = elabLocalToProject && not (isIndefiniteOrInstantiation elabModuleShape) -- TODO(#9493): We can only cover libraries in the same package -- as the testsuite - && configuredPkgSourceId == elabPkgSourceId + && elabPkgSourceId configuredPkg == pkgSID -- Libraries only! We don't cover testsuite modules, so we never need -- the paths to their mix dirs. Furthermore, we do not install testsuites... && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) + -- We only want coverage for libraries which are dependencies of the given one + && pkgSID `elem` map (confSrcId . fst) libDeps isIndefiniteOrInstantiation :: ModuleShape -> Bool isIndefiniteOrInstantiation = not . Set.null . modShapeRequires 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 @@ -59,17 +59,17 @@ -- @since 3.12.0.0 packageSetupScriptStyle :: PackageDescription -> SetupScriptStyle packageSetupScriptStyle pkg - | buildType pkg == Custom + | customOrHooks , Just setupbi <- setupBuildInfo pkg -- does have a custom-setup stanza , not (defaultSetupDepends setupbi) -- but not one we added ourselves = SetupCustomExplicitDeps - | buildType pkg == Custom + | customOrHooks , Just setupbi <- setupBuildInfo pkg -- does have a custom-setup stanza , defaultSetupDepends setupbi -- that we had to add ourselves = SetupCustomImplicitDeps - | buildType pkg == Custom + | customOrHooks , Nothing <- setupBuildInfo pkg -- we get this case pre-solver = SetupCustomImplicitDeps @@ -79,6 +79,8 @@ SetupNonCustomExternalLib | otherwise = SetupNonCustomInternalLib + where + customOrHooks = buildType pkg `elem` [Custom, Hooks] -- | Part of our Setup.hs handling policy is implemented by getting the solver -- to work out setup dependencies for packages. The solver already handles @@ -131,11 +133,10 @@ -- For other build types (like Simple) if we still need to compile an -- external Setup.hs, it'll be one of the simple ones that only depends - -- on Cabal and base. + -- on Cabal. SetupNonCustomExternalLib -> Just [ Dependency cabalPkgname cabalConstraint mainLibSet - , Dependency basePkgname anyVersion mainLibSet ] where cabalConstraint = orLaterVersion (csvToVersion (specVersion pkg)) @@ -215,9 +216,8 @@ fromMaybe [] $ Graph.closure libDepGraph (CD.setupDeps deps) -cabalPkgname, basePkgname :: PackageName +cabalPkgname :: PackageName cabalPkgname = mkPackageName "Cabal" -basePkgname = mkPackageName "base" legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] legacyCustomSetupPkgs compiler (Platform _ os) = 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 @@ -86,6 +86,7 @@ import Distribution.Backpack import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (IsNode (..)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.ModuleName (ModuleName) import Distribution.Package @@ -106,20 +107,19 @@ , ReplOptions , TestShowDetails ) +import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.OptionalStanza import Distribution.System import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion +import Distribution.Utils.Path (getSymbolicPath) import Distribution.Verbosity (normal) import Distribution.Version -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Simple.Utils (ordNub) -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.OptionalStanza - import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map @@ -262,13 +262,13 @@ -- that a user enabled tests globally, and some local packages -- just happen not to have any tests. (But perhaps we should -- warn if ALL local packages don't have any tests.) - , elabPackageDbs :: [Maybe PackageDB] - , elabSetupPackageDBStack :: PackageDBStack - , elabBuildPackageDBStack :: PackageDBStack - , elabRegisterPackageDBStack :: PackageDBStack - , elabInplaceSetupPackageDBStack :: PackageDBStack - , elabInplaceBuildPackageDBStack :: PackageDBStack - , elabInplaceRegisterPackageDBStack :: PackageDBStack + , elabPackageDbs :: [Maybe PackageDBCWD] + , elabSetupPackageDBStack :: PackageDBStackCWD + , elabBuildPackageDBStack :: PackageDBStackCWD + , elabRegisterPackageDBStack :: PackageDBStackCWD + , elabInplaceSetupPackageDBStack :: PackageDBStackCWD + , elabInplaceBuildPackageDBStack :: PackageDBStackCWD + , elabInplaceRegisterPackageDBStack :: PackageDBStackCWD , elabPkgDescriptionOverride :: Maybe CabalFileText , -- TODO: make per-component variants of these flags elabBuildOptions :: LBC.BuildOptions @@ -300,8 +300,9 @@ , elabHaddockContents :: Maybe PathTemplate , elabHaddockIndex :: Maybe PathTemplate , elabHaddockBaseUrl :: Maybe String - , elabHaddockLib :: Maybe String + , elabHaddockResourcesDir :: Maybe String , elabHaddockOutputDir :: Maybe FilePath + , elabHaddockUseUnicode :: Bool , elabTestMachineLog :: Maybe PathTemplate , elabTestHumanLog :: Maybe PathTemplate , elabTestShowDetails :: Maybe TestShowDetails @@ -457,9 +458,7 @@ BuildInplaceOnly{} -> Just ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" - , Just $ - srcPath (elabPkgSourceLocation pkg) - dataDir (elabPkgDescription pkg) + , Just dataDirPath ) where srcPath (LocalUnpackedPackage path) = path @@ -473,7 +472,17 @@ "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" unpackedPath = distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg + rawDataDir = getSymbolicPath $ dataDir (elabPkgDescription pkg) + pkgDir = srcPath (elabPkgSourceLocation pkg) + dataDirPath + | null rawDataDir = + pkgDir + | otherwise = + pkgDir rawDataDir +-- NB: rawDataDir may be absolute, in which case +-- () drops its first argument. + instance Package ElaboratedConfiguredPackage where packageId = elabPkgSourceId @@ -754,6 +763,7 @@ data NotPerComponentBuildType = CuzConfigureBuildType | CuzCustomBuildType + | CuzHooksBuildType | CuzMakeBuildType deriving (Eq, Show, Generic) @@ -771,6 +781,7 @@ "build-type is " ++ case bt of CuzConfigureBuildType -> "Configure" CuzCustomBuildType -> "Custom" + CuzHooksBuildType -> "Hooks" CuzMakeBuildType -> "Make" CuzCabalSpecVersion -> "cabal-version is less than 1.8" CuzNoBuildableComponents -> "there are no buildable components" 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,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} + module Distribution.Client.Reconfigure (Check (..), reconfigure) where import Distribution.Client.Compat.Prelude @@ -8,10 +10,11 @@ import Distribution.Simple.Configure (localBuildInfoFile) import Distribution.Simple.Setup (Flag, flagToMaybe, toFlag) import Distribution.Simple.Utils - ( defaultPackageDesc + ( defaultPackageDescCwd , existsAndIsMoreRecentThan , info ) +import Distribution.Utils.Path import Distribution.Client.Config (SavedConfig (..)) import Distribution.Client.Configure (readConfigFlags) @@ -21,7 +24,8 @@ ( userPackageEnvironmentFile ) import Distribution.Client.Setup - ( ConfigExFlags + ( CommonSetupFlags (..) + , ConfigExFlags , ConfigFlags (..) , GlobalFlags (..) ) @@ -80,7 +84,7 @@ -- ^ configure action -> Verbosity -- ^ Verbosity setting - -> FilePath + -> SymbolicPath Pkg (Dir Dist) -- ^ \"dist\" prefix -> Flag (Maybe Int) -- ^ -j flag for reinstalling add-source deps. @@ -104,7 +108,7 @@ globalFlags config = do - savedFlags@(_, _) <- readConfigFlags dist + savedFlags@(_, _) <- readConfigFlags $ getSymbolicPath dist useNix <- fmap isJust (findNixExpr globalFlags config) alreadyInNixShell <- inNixShell @@ -121,7 +125,7 @@ -- No, because 'nixShell' doesn't spawn a new process if it is already -- running in a Nix shell. - nixInstantiate verbosity dist False globalFlags config + nixInstantiate verbosity (getSymbolicPath dist) False globalFlags config return config else do let checks :: Check (ConfigFlags, ConfigExFlags) @@ -138,12 +142,18 @@ when frc $ configureAction flags extraArgs globalFlags return config' where + mbWorkDir = flagToMaybe $ configWorkingDir $ savedConfigureFlags config -- Changing the verbosity does not require reconfiguration, but the new -- verbosity should be used if reconfiguring. checkVerb :: Check (ConfigFlags, b) checkVerb = Check $ \_ (configFlags, configExFlags) -> do - let configFlags' :: ConfigFlags - configFlags' = configFlags{configVerbosity = toFlag verbosity} + let common = configCommonFlags configFlags + configFlags' :: ConfigFlags + configFlags' = + configFlags + { configCommonFlags = + common{setupVerbosity = toFlag verbosity} + } return (mempty, (configFlags', configExFlags)) -- Reconfiguration is required if @--build-dir@ changes. @@ -151,18 +161,25 @@ checkDist = Check $ \_ (configFlags, configExFlags) -> do -- Always set the chosen @--build-dir@ before saving the flags, -- or bad things could happen. - savedDist <- findSavedDistPref config (configDistPref configFlags) + let common = configCommonFlags configFlags + savedDist <- findSavedDistPref config (setupDistPref common) let distChanged :: Bool distChanged = dist /= savedDist when distChanged $ info verbosity "build directory changed" let configFlags' :: ConfigFlags - configFlags' = configFlags{configDistPref = toFlag dist} + configFlags' = + configFlags + { configCommonFlags = + common{setupDistPref = toFlag dist} + } return (Any distChanged, (configFlags', configExFlags)) checkOutdated :: Check (ConfigFlags, b) checkOutdated = Check $ \_ flags@(configFlags, _) -> do - let buildConfig :: FilePath - buildConfig = localBuildInfoFile dist + let common = configCommonFlags configFlags + buildConfig, userCabalConfig :: FilePath + buildConfig = interpretSymbolicPath mbWorkDir $ localBuildInfoFile dist + userCabalConfig = userPackageEnvironmentFile -- Has the package ever been configured? If not, reconfiguration is -- required. @@ -173,7 +190,7 @@ -- to force reconfigure. Note that it's possible to use @cabal.config@ -- even without sandboxes. userPackageEnvironmentFileModified <- - existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig + existsAndIsMoreRecentThan userCabalConfig buildConfig when userPackageEnvironmentFileModified $ info verbosity @@ -185,11 +202,12 @@ -- Is the configuration older than the package description? descrFile <- maybe - (defaultPackageDesc verbosity) + (relativeSymbolicPath <$> defaultPackageDescCwd verbosity) return - (flagToMaybe (configCabalFilePath configFlags)) - outdated <- existsAndIsMoreRecentThan descrFile buildConfig - when outdated $ info verbosity (descrFile ++ " was changed") + (flagToMaybe (setupCabalFilePath common)) + let descrPath = interpretSymbolicPath mbWorkDir descrFile + outdated <- existsAndIsMoreRecentThan descrPath buildConfig + when outdated $ info verbosity (getSymbolicPath descrFile ++ " was changed") let failed :: Any failed = 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,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- @@ -26,20 +27,30 @@ , PackageDescription (..) , TestSuite (..) ) -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import Distribution.Simple (PackageDBX (..)) +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths (exeExtension) import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor) +import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.LocalBuildInfo ( ComponentName (..) , LocalBuildInfo (..) , buildDir , depLibraryPaths + , interpretSymbolicPathLBI + , mbWorkDirLBI ) +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Register (internalPackageDBPath) + +import Distribution.Simple.Setup (ConfigFlags (..)) import Distribution.Simple.Utils ( addLibraryPath , dieWithException , notice - , rawSystemExitWithEnv + , rawSystemExitWithEnvCwd , warn ) import Distribution.System (Platform (..)) @@ -49,8 +60,7 @@ import Distribution.Client.Errors import Distribution.Compat.Environment (getEnvironment) -import System.Directory (getCurrentDirectory) -import System.FilePath ((<.>), ()) +import Distribution.Utils.Path -- | Return the executable to run and any extra arguments that should be -- forwarded to it. Die in case of error. @@ -133,42 +143,61 @@ -- | Run a given executable. run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () run verbosity lbi exe exeArgs = do - curDir <- getCurrentDirectory - let buildPref = buildDir lbi + let distPref = fromFlag $ configDistPref $ configFlags lbi + buildPref = buildDir lbi pkg_descr = localPkgDescr lbi - dataDirEnvVar = - ( pkgPathEnvVar pkg_descr "datadir" - , curDir dataDir pkg_descr - ) + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + mbWorkDir = mbWorkDirLBI lbi + internalPkgDb = internalPackageDBPath lbi distPref + lbiForExe = + lbi + { withPackageDB = withPackageDB lbi ++ [SpecificPackageDB internalPkgDb] + , -- Include any build-tool-depends on build tools internal to the current package. + withPrograms = + addInternalBuildTools + pkg_descr + lbi + (buildInfo exe) + (withPrograms lbi) + } (path, runArgs) <- let exeName' = prettyShow $ exeName exe - in case compilerFlavor (compiler lbi) of + in case compilerFlavor (compiler lbiForExe) of GHCJS -> do let (script, cmd, cmdArgs) = GHCJS.runCmd - (withPrograms lbi) - (buildPref exeName' exeName') + (withPrograms lbiForExe) + (i buildPref exeName' exeName') script' <- tryCanonicalizePath script return (cmd, cmdArgs ++ [script']) _ -> do p <- tryCanonicalizePath $ - buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) + i buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbiForExe)) return (p, []) - env <- (dataDirEnvVar :) <$> getEnvironment + -- Compute the appropriate environment for running the executable + existingEnv <- getEnvironment + let progDb = withPrograms lbiForExe + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar + overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides) + let env = overrideEnv ++ existingEnv + -- Add (DY)LD_LIBRARY_PATH if needed env' <- - if withDynExe lbi + if withDynExe lbiForExe then do - let (Platform _ os) = hostPlatform lbi - clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of + let (Platform _ os) = hostPlatform lbiForExe + clbi <- case componentNameTargets' pkg_descr lbiForExe (CExeName (exeName exe)) of [target] -> return (targetCLBI target) [] -> dieWithException verbosity CouldNotFindExecutable _ -> dieWithException verbosity FoundMultipleMatchingExes - paths <- depLibraryPaths True False lbi clbi + paths <- depLibraryPaths True False lbiForExe clbi return (addLibraryPath os paths env) else return env + notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..." - rawSystemExitWithEnv verbosity path (runArgs ++ exeArgs) env' + rawSystemExitWithEnvCwd verbosity mbWorkDir path (runArgs ++ exeArgs) env' 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -28,7 +29,8 @@ , loadConfig ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , GlobalFlags (..) , configCompilerAux' ) @@ -56,8 +58,14 @@ , fromFlagOrDefault ) import Distribution.System (Platform) +import Distribution.Utils.Path hiding + ( (<.>) + , () + ) -import System.Directory (getCurrentDirectory) +import System.Directory + ( getCurrentDirectory + ) -- * Basic sandbox functions. @@ -116,11 +124,11 @@ return config' -- | Return the saved \"dist/\" prefix, or the default prefix. -findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath +findSavedDistPref :: SavedConfig -> Flag (SymbolicPath Pkg (Dir Dist)) -> IO (SymbolicPath Pkg (Dir Dist)) findSavedDistPref config flagDistPref = do let defDistPref = useDistPref defaultSetupScriptOptions flagDistPref' = - configDistPref (savedConfigureFlags config) + (setupDistPref (configCommonFlags $ savedConfigureFlags config)) `mappend` flagDistPref findDistPref defDistPref flagDistPref' @@ -134,8 +142,9 @@ :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) getPersistOrConfigCompiler configFlags = do - distPref <- findDistPrefOrDefault (configDistPref configFlags) - mlbi <- maybeGetPersistBuildConfig distPref + let common = configCommonFlags configFlags + distPref <- findDistPrefOrDefault (setupDistPref common) + mlbi <- maybeGetPersistBuildConfig (flagToMaybe $ setupWorkingDir common) distPref case mlbi of Nothing -> do configCompilerAux' configFlags Just lbi -> 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,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- 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 @@ -75,7 +75,8 @@ ( runRebuild ) import Distribution.Client.Setup - ( ConfigFlags (..) + ( CommonSetupFlags (..) + , ConfigFlags (..) , GlobalFlags (..) ) import Distribution.Client.TargetSelector @@ -195,6 +196,9 @@ import Data.ByteString.Lazy () import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Utils.Path + ( unsafeMakeSymbolicPath + ) import System.Directory ( canonicalizePath , doesFileExist @@ -203,6 +207,7 @@ ) import System.FilePath ( makeRelative + , normalise , takeDirectory , takeFileName , () @@ -332,7 +337,7 @@ act tc' ctx' sels where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) ignoreProject = flagIgnoreProject projectFlags cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) @@ -382,7 +387,7 @@ build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform exePath = build_dir "bin" scriptExeFileName script - exePathRel = makeRelative projectRoot exePath + exePathRel = makeRelative (normalise projectRoot) exePath executable' = executable @@ -402,7 +407,9 @@ -- but still grantee that it's deleted if they do create it -- 2) Because the path returned by createTempDirectory is not predicable getMkTmp m = return $ do - tmpDir <- getTemporaryDirectory >>= flip createTempDirectory "cabal-repl." + tmpBaseDir <- getTemporaryDirectory + tmpRelDir <- createTempDirectory tmpBaseDir "cabal-repl." + let tmpDir = tmpBaseDir tmpRelDir putMVar m tmpDir return tmpDir rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive) @@ -458,12 +465,12 @@ else writePackageFile return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg])) --- | Add add the executable metadata to the context and write a .cabal file. +-- | Add the executable metadata to the context and write a .cabal file. updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do let projectRoot = distProjectRootDirectory $ distDirLayout ctx - absScript <- canonicalizePath scriptPath + absScript <- unsafeMakeSymbolicPath . makeRelative (normalise projectRoot) <$> canonicalizePath scriptPath let sourcePackage = fakeProjectSourcePackage projectRoot 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 @@ -189,13 +189,8 @@ ++ " for " ++ show uri -#if MIN_VERSION_base(4,8,0) deriving instance Show UnexpectedResponse instance Exception UnexpectedResponse where displayException = HC.pretty -#else -instance Show UnexpectedResponse where show = HC.pretty -instance Exception UnexpectedResponse -#endif wrapCustomEx :: ( ( HC.Throws UnexpectedResponse 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 @@ -23,8 +23,10 @@ , RepoContext (..) , withRepoContext , configureCommand + , CommonSetupFlags (..) , ConfigFlags (..) , configureOptions + , filterCommonFlags , filterConfigureFlags , configPackageDB' , configCompilerAux' @@ -185,6 +187,7 @@ , BooleanFlag (..) , BuildFlags (..) , CleanFlags (..) + , CommonSetupFlags (..) , ConfigFlags (..) , CopyFlags (..) , HaddockFlags (..) @@ -197,6 +200,7 @@ , optionVerbosity , readPackageDbList , showPackageDbList + , testCommonFlags , trueArg ) import qualified Distribution.Simple.Setup as Cabal @@ -206,7 +210,9 @@ import Distribution.System (Platform) import Distribution.Types.GivenComponent ( GivenComponent (..) + , PromisedComponent (..) ) +import Distribution.Types.PackageId import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint (..) ) @@ -222,6 +228,7 @@ import Distribution.Version ( Version , mkVersion + , nullVersion ) import Control.Exception @@ -627,6 +634,34 @@ configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions = commandOptions configureCommand +filterCommonFlags :: CommonSetupFlags -> Version -> CommonSetupFlags +filterCommonFlags 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 [1, 2, 5] = flags_1_2_5 + | cabalLibVersion < mkVersion [2, 1, 0] = flags_2_1_0 + | cabalLibVersion < mkVersion [3, 13, 0] = flags_3_13_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags + flags_3_13_0 = + flags_latest + { setupWorkingDir = NoFlag + } + -- Cabal < 3.13 does not support the --working-dir flag. + flags_2_1_0 = + flags_3_13_0 + { -- Cabal < 2.1 doesn't know about -v +timestamp modifier + setupVerbosity = fmap verboseNoTimestamp (setupVerbosity flags_3_13_0) + } + flags_1_2_5 = + flags_2_1_0 + { -- Cabal < 1.25 doesn't have extended verbosity syntax + setupVerbosity = + fmap verboseNoFlags (setupVerbosity flags_2_1_0) + } + -- | Given some 'ConfigFlags' for the version of Cabal that -- cabal-install was built with, and a target older 'Version' of -- Cabal that we want to pass these flags to, convert the @@ -636,10 +671,18 @@ -- in some cases it may also mean "emulating" a feature using -- some more legacy flags. filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags -filterConfigureFlags flags cabalLibVersion +filterConfigureFlags flags cabalLibVersion = + let flags' = filterConfigureFlags' flags cabalLibVersion + in flags' + { configCommonFlags = + filterCommonFlags (configCommonFlags flags') cabalLibVersion + } + +filterConfigureFlags' :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags' flags cabalLibVersion -- NB: we expect the latest version to be the most common case, -- so test it first. - | cabalLibVersion >= mkVersion [3, 11, 0] = flags_latest + | cabalLibVersion >= mkVersion [3, 13, 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 @@ -661,6 +704,7 @@ | cabalLibVersion < mkVersion [2, 5, 0] = flags_2_5_0 | 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 | otherwise = error "the impossible just happened" -- see first guard where flags_latest = @@ -672,8 +716,26 @@ configConstraints = [] } + flags_3_13_0 = + let scrubVersion pc = + pc + { promisedComponentPackage = + (promisedComponentPackage pc){pkgVersion = nullVersion} + } + in -- Earlier Cabal versions don't understand about .. + flags_latest + { -- Building profiled shared libraries + configProfShared = NoFlag + , configIgnoreBuildTools = NoFlag + , -- Older versions of Cabal don't include the package version in the + -- --promised-dependency flag, by setting the version to nullVersion, + -- it won't be printed. + configPromisedDependencies = + map scrubVersion (configPromisedDependencies flags) + } + flags_3_11_0 = - flags_latest + flags_3_13_0 { -- It's too late to convert configPromisedDependencies to anything -- meaningful, so we just assert that it's empty. -- We add a Cabal>=3.11 constraint before solving when multi-repl is @@ -717,9 +779,7 @@ flags_2_1_0 = flags_2_5_0 - { -- Cabal < 2.1 doesn't know about -v +timestamp modifier - configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) - , -- Cabal < 2.1 doesn't know about ---static + { -- Cabal < 2.1 doesn't know about ---static configStaticLib = NoFlag , configSplitSections = NoFlag } @@ -728,8 +788,6 @@ flags_2_1_0 { -- Cabal < 1.25.0 doesn't know about --dynlibdir. configInstallDirs = configInstallDirs_1_25_0 - , -- Cabal < 1.25 doesn't have extended verbosity syntax - configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0) , -- Cabal < 1.25 doesn't support --deterministic configDeterministic = mempty } @@ -747,7 +805,7 @@ -- Cabal < 1.23 doesn't know about '--profiling-detail'. -- Cabal < 1.23 has a hacked up version of 'enable-profiling' -- which we shouldn't use. - (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags + (tryLibProfiling, _tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling flags flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag @@ -822,11 +880,15 @@ -- | Configure the compiler, but reduce verbosity during this step. configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAux' configFlags = +configCompilerAux' configFlags = do + let commonFlags = configCommonFlags configFlags configCompilerAuxEx configFlags { -- FIXME: make configCompilerAux use a sensible verbosity - configVerbosity = fmap lessVerbose (configVerbosity configFlags) + configCommonFlags = + commonFlags + { setupVerbosity = fmap lessVerbose (setupVerbosity commonFlags) + } } -- ------------------------------------------------------------ @@ -1097,7 +1159,15 @@ -- in some cases it may also mean "emulating" a feature using -- some more legacy flags. filterTestFlags :: TestFlags -> Version -> TestFlags -filterTestFlags flags cabalLibVersion +filterTestFlags flags cabalLibVersion = + let flags' = filterTestFlags' flags cabalLibVersion + in flags' + { testCommonFlags = + filterCommonFlags (testCommonFlags flags') cabalLibVersion + } + +filterTestFlags' :: TestFlags -> Version -> TestFlags +filterTestFlags' flags cabalLibVersion -- NB: we expect the latest version to be the most common case, -- so test it first. | cabalLibVersion >= mkVersion [3, 0, 0] = flags_latest @@ -2335,7 +2405,15 @@ args_2_3_0 = [] filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags -filterHaddockFlags flags cabalLibVersion +filterHaddockFlags flags cabalLibVersion = + let flags' = filterHaddockFlags' flags cabalLibVersion + in flags' + { haddockCommonFlags = + filterCommonFlags (haddockCommonFlags flags') cabalLibVersion + } + +filterHaddockFlags' :: HaddockFlags -> Version -> HaddockFlags +filterHaddockFlags' flags cabalLibVersion | cabalLibVersion >= mkVersion [2, 3, 0] = flags_latest | cabalLibVersion < mkVersion [2, 3, 0] = flags_2_3_0 | otherwise = flags_latest @@ -2345,7 +2423,10 @@ flags_2_3_0 = flags_latest { -- Cabal < 2.3 doesn't know about per-component haddock - haddockArgs = [] + haddockCommonFlags = + (haddockCommonFlags flags_latest) + { setupTargets = [] + } } haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] @@ -2376,8 +2457,9 @@ , "use-index" , "for-hackage" , "base-url" - , "lib" + , "resources-dir" , "output-dir" + , "use-unicode" ] ] 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {- FOURMOLU_DISABLE -} @@ -33,10 +34,6 @@ import qualified Distribution.Backpack as Backpack import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) -import Distribution.Compiler - ( CompilerFlavor (GHC, GHCJS) - , buildCompilerId - ) import qualified Distribution.Make as Make import Distribution.Package ( ComponentId @@ -64,11 +61,6 @@ , exeExtension ) import Distribution.Simple.Compiler - ( Compiler (compilerId) - , PackageDB (..) - , PackageDBStack - , compilerFlavor - ) import Distribution.Simple.Configure ( configCompilerEx ) @@ -82,14 +74,16 @@ import Distribution.Simple.Program ( ProgramDb , emptyProgramDb - , getDbProgramOutput + , getDbProgramOutputCwd , getProgramSearchPath , ghcProgram , ghcjsProgram - , runDbProgram + , runDbProgramCwd ) import Distribution.Simple.Program.Db - ( prependProgramSearchPath + ( configureAllKnownPrograms + , prependProgramSearchPath + , progOverrideEnv ) import Distribution.Simple.Program.Find ( programSearchPathAsPATHVar @@ -123,7 +117,7 @@ import Distribution.Client.Types import Distribution.Client.Utils ( existsAndIsMoreRecentThan - , inDir + , makeRelativeToDirS #ifdef mingw32_HOST_OS , canonicalizePathNoThrow #endif @@ -133,6 +127,9 @@ , 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 (..) @@ -146,13 +143,14 @@ , renderGhcOptions ) import Distribution.Simple.Setup - ( Flag (..) + ( Flag (..), CommonSetupFlags (..), GlobalFlags (..) ) import Distribution.Simple.Utils ( cabalVersion , copyFileVerbose , createDirectoryIfMissingVerbose , debug + , die' , dieWithException , info , infoNoWrap @@ -176,6 +174,8 @@ import Distribution.Verbosity import Data.List (foldl1') +import qualified Data.Map.Lazy as Map +import Distribution.Simple.Setup (globalCommand) import Distribution.Client.Compat.ExecutablePath (getExecutablePath) import Distribution.Compat.Process (proc) import System.Directory (doesFileExist) @@ -250,12 +250,12 @@ -- if needed. , useCompiler :: Maybe Compiler , usePlatform :: Maybe Platform - , usePackageDB :: PackageDBStack + , usePackageDB :: PackageDBStackCWD , usePackageIndex :: Maybe InstalledPackageIndex , useProgramDb :: ProgramDb - , useDistPref :: FilePath + , useDistPref :: SymbolicPath Pkg (Dir Dist) , useLoggingHandle :: Maybe Handle - , useWorkingDir :: Maybe FilePath + , useWorkingDir :: Maybe (SymbolicPath CWD (Dir Pkg)) , useExtraPathEnv :: [FilePath] -- ^ Extra things to add to PATH when invoking the setup script. , useExtraEnvOverrides :: [(String, Maybe FilePath)] @@ -339,10 +339,12 @@ } workingDir :: SetupScriptOptions -> FilePath -workingDir options = - case fromMaybe "" (useWorkingDir options) of - [] -> "." - dir -> dir +workingDir options = case useWorkingDir options of + Just dir + | let fp = getSymbolicPath dir + , not $ null fp + -> fp + _ -> "." -- | A @SetupRunner@ implements a 'SetupMethod'. type SetupRunner = @@ -382,9 +384,10 @@ , setupPackage = pkg } where + mbWorkDir = useWorkingDir options getPkg = - tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) - >>= readGenericPackageDescription verbosity + (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 @@ -398,6 +401,7 @@ -> 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' @@ -476,14 +480,20 @@ -> Setup -> CommandUI flags -- ^ command definition + -> (flags -> CommonSetupFlags) -> flags -- ^ command flags -> [String] -- ^ extra command-line arguments -> IO () -runSetupCommand verbosity setup cmd flags extraArgs = do - let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs - runSetup verbosity setup args +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. @@ -492,18 +502,23 @@ -> SetupScriptOptions -> Maybe PackageDescription -> CommandUI flags - -> (Version -> flags) + -> (flags -> CommonSetupFlags) + -> (Version -> IO flags) -- ^ produce command flags given the Cabal library version -> (Version -> [String]) -> IO () -setupWrapper verbosity options mpkg cmd flags extraArgs = do +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 - (flags $ setupVersion setup) - (extraArgs $ setupVersion setup) + getCommonFlags + flags + extraArgs -- ------------------------------------------------------------ @@ -511,6 +526,7 @@ -- ------------------------------------------------------------ +-- | Run a Setup script by directly invoking the @Cabal@ library. internalSetupMethod :: SetupRunner internalSetupMethod verbosity options bt args = do info verbosity $ @@ -518,18 +534,26 @@ ++ show bt ++ " and args:\n " ++ show args - inDir (useWorkingDir options) $ do - withEnv "HASKELL_DIST_DIR" (useDistPref options) $ - withExtraPathEnv (useExtraPathEnv options) $ - withEnvOverrides (useExtraEnvOverrides options) $ - buildTypeAction bt 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.defaultMainWithHooksArgs - Simple.autoconfUserHooks + Simple.defaultMainWithSetupHooksArgs + Simple.autoconfSetupHooks buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Hooks = error "buildTypeAction Hooks" buildTypeAction Custom = error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () @@ -539,7 +563,7 @@ Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle - progDb <- prependProgramSearchPath verbosity (useExtraPathEnv options) (useProgramDb options) + progDb <- prependProgramSearchPath verbosity (useExtraPathEnv options) (useExtraEnvOverrides options) (useProgramDb options) searchpath <- programSearchPathAsPATHVar $ getProgramSearchPath progDb @@ -547,16 +571,16 @@ env <- getEffectiveEnvironment $ [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) + , ("HASKELL_DIST_DIR", Just (getSymbolicPath $ useDistPref options)) ] - ++ useExtraEnvOverrides options + ++ progOverrideEnv progDb let loggingHandle = case useLoggingHandle options of Nothing -> Inherit Just hdl -> UseHandle hdl cp = (proc path args) - { Process.cwd = useWorkingDir options + { Process.cwd = fmap getSymbolicPath $ useWorkingDir options , Process.env = env , Process.std_out = loggingHandle , Process.std_err = loggingHandle @@ -642,7 +666,7 @@ debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options) - createDirectoryIfMissingVerbose verbosity True setupDir + createDirectoryIfMissingVerbose verbosity True $ i setupDir (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion path <- @@ -668,7 +692,7 @@ -- See 'Note: win32 clean hack' above. #ifdef mingw32_HOST_OS -- setupProgFile may not exist if we're using a cached program - setupProgFile' <- canonicalizePathNoThrow setupProgFile + setupProgFile' <- canonicalizePathNoThrow $ i setupProgFile let win32CleanHackNeeded = (useWin32CleanHack options) -- Skip when a cached setup script is used. @@ -680,13 +704,19 @@ return (cabalLibVersion, ExternalMethod path', options'') where - setupDir = workingDir options useDistPref options "setup" - setupVersionFile = setupDir "setup" <.> "version" - setupHs = setupDir "setup" <.> "hs" - setupProgFile = setupDir "setup" <.> exeExtension buildPlatform + 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) + useCachedSetupExecutable = + bt == Simple || bt == Configure || bt == Make maybeGetInstalledPackages :: SetupScriptOptions @@ -760,12 +790,12 @@ doesFileExist cachedSetupProgFile else (&&) - <$> setupProgFile `existsAndIsMoreRecentThan` setupHs - <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile + <$> i setupProgFile `existsAndIsMoreRecentThan` i setupHs + <*> i setupProgFile `existsAndIsMoreRecentThan` i setupVersionFile writeSetupVersionFile :: Version -> IO () writeSetupVersionFile version = - writeFile setupVersionFile (show version ++ "\n") + writeFile (i setupVersionFile) (show version ++ "\n") installedVersion :: IO @@ -786,7 +816,7 @@ savedVersion :: IO (Maybe Version) savedVersion = do - versionString <- readFile setupVersionFile `catchIO` \_ -> return "" + versionString <- readFile (i setupVersionFile) `catchIO` \_ -> return "" case reads versionString of [(version, s)] | all isSpace s -> return (Just version) _ -> return Nothing @@ -799,24 +829,44 @@ unless (useHs || useLhs) $ dieWithException verbosity UpdateSetupScript let src = (if useHs then customSetupHs else customSetupLhs) - srcNewer <- src `moreRecentFile` setupHs + srcNewer <- src `moreRecentFile` i setupHs when srcNewer $ if useHs - then copyFileVerbose verbosity src setupHs - else runSimplePreProcessor ppUnlit src setupHs verbosity + 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 setupHs (buildTypeScript cabalLibVersion) + rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) buildTypeScript :: Version -> BS.ByteString - buildTypeScript cabalLibVersion = case bt of + buildTypeScript cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of Simple -> "import Distribution.Simple; main = defaultMain\n" Configure - | cabalLibVersion >= mkVersion [1, 3, 10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" - | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" + | 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 @@ -978,11 +1028,19 @@ 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') $ + 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 - (useProgramDb options') + setupProgDb cachedSetupProgFile return cachedSetupProgFile where @@ -1001,12 +1059,13 @@ cabalLibVersion maybeCabalLibInstalledPkgId forceCompile = do - setupHsNewer <- setupHs `moreRecentFile` setupProgFile - cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + 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 @@ -1018,32 +1077,24 @@ (\ipkgid -> [(ipkgid, cabalPkgid)]) maybeCabalLibInstalledPkgId - -- With 'useDependenciesExclusive' we enforce the deps specified, - -- so only the given ones can be used. Otherwise we allow the use - -- of packages in the ambient environment, and add on a dep on the - -- Cabal library (unless 'useDependencies' already contains one). - -- - -- With 'useVersionMacros' we use a version CPP macros .h file. - -- - -- Both of these options should be enabled for packages that have - -- opted-in and declared a custom-settup stanza. - -- + -- 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' = - useDependencies options' + | (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' - ++ if any - (isCabalPkgId . snd) - (useDependencies options') - then [] - else cabalDep + useDependencies options' ++ cabalDep addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) , defaultRenaming ) - cppMacrosFile = setupDir "setup_macros.h" + cppMacrosFile = setupDir Cabal.Path. makeRelativePathEx "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if @@ -1052,41 +1103,52 @@ ghcOptVerbosity = Flag (min verbosity normal) , ghcOptMode = Flag GhcModeMake , ghcOptInputFiles = toNubListR [setupHs] - , ghcOptOutputFile = Flag setupProgFile - , ghcOptObjDir = Flag setupDir - , ghcOptHiDir = Flag setupDir + , ghcOptOutputFile = Flag $ setupProgFile + , ghcOptObjDir = Flag $ setupDir + , ghcOptHiDir = Flag $ setupDir , ghcOptSourcePathClear = Flag True , ghcOptSourcePath = case bt of - Custom -> toNubListR [workingDir options'] + Custom -> toNubListR [sameDirectory] + Hooks -> toNubListR [sameDirectory] _ -> mempty - , ghcOptPackageDBs = usePackageDB options'' + , 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 cppMacrosFile $ + rewriteFileEx verbosity (i cppMacrosFile) $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) case useLoggingHandle options of - Nothing -> runDbProgram verbosity program progdb ghcCmdLine + Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine -- If build logging is enabled, redirect compiler output to -- the log file. - (Just logHandle) -> do + Just logHandle -> do output <- - getDbProgramOutput + getDbProgramOutputCwd verbosity + mbWorkDir program progdb ghcCmdLine hPutStr logHandle output - return setupProgFile + return $ i setupProgFile -isCabalPkgId :: PackageIdentifier -> Bool +isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" +isBasePkgId (PackageIdentifier pname _) = pname == mkPackageName "base" 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 @@ -103,7 +103,7 @@ } ) = do - traverse_ needIfExists fs + traverse_ (needIfExists . getSymbolicPath) fs needBuildInfo pkg_descr bi [] needExecutable :: PackageDescription -> Executable -> Rebuild () @@ -116,14 +116,14 @@ ) = do needBuildInfo pkg_descr bi [] - needMainFile bi mainPath + needMainFile bi $ getSymbolicPath mainPath needTestSuite :: PackageDescription -> TestSuite -> Rebuild () needTestSuite pkg_descr t = case testInterface t of TestSuiteExeV10 _ mainPath -> do needBuildInfo pkg_descr bi [] - needMainFile bi mainPath + needMainFile bi $ getSymbolicPath mainPath TestSuiteLibV09 _ m -> needBuildInfo pkg_descr bi [m] TestSuiteUnsupported _ -> return () -- soft fail @@ -157,7 +157,7 @@ case benchmarkInterface bm of BenchmarkExeV10 _ mainPath -> do needBuildInfo pkg_descr bi [] - needMainFile bi mainPath + needMainFile bi $ getSymbolicPath mainPath BenchmarkUnsupported _ -> return () -- soft fail where bi :: BuildInfo @@ -170,18 +170,21 @@ findNeededModules builtinHaskellSuffixes findNeededModules builtinHaskellBootSuffixes root <- askRoot - expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) root fpath + expandedExtraSrcFiles <- liftIO $ + fmap concat . for (extraSrcFiles pkg_descr) $ + \fpath -> + matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) (Just $ makeSymbolicPath root) fpath traverse_ needIfExists $ concat - [ cSources bi - , cxxSources bi - , jsSources bi - , cmmSources bi - , asmSources bi - , expandedExtraSrcFiles + [ map getSymbolicPath $ cSources bi + , map getSymbolicPath $ cxxSources bi + , map getSymbolicPath $ jsSources bi + , map getSymbolicPath $ cmmSources bi + , map getSymbolicPath $ asmSources bi + , map getSymbolicPath $ expandedExtraSrcFiles ] - for_ (installIncludes bi) $ \f -> - findFileMonitored ("." : includeDirs bi) f + for_ (fmap getSymbolicPath $ installIncludes bi) $ \f -> + findFileMonitored ("." : fmap getSymbolicPath (includeDirs bi)) f >>= maybe (return ()) need where findNeededModules :: [Suffix] -> Rebuild () 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 @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -- | Utilities to implement cabal @v2-sdist@. module Distribution.Client.SrcDist @@ -12,16 +13,19 @@ import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) import Control.Monad.Trans (liftIO) import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell) -import System.FilePath (normalise, takeDirectory, ()) -import Distribution.Client.Utils (tryFindAddSourcePackageDesc) +import Distribution.Client.Errors +import Distribution.Client.Utils (tryReadAddSourcePackageDesc) import Distribution.Package (Package (packageId)) import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.Simple.PackageDescription (readGenericPackageDescription) import Distribution.Simple.PreProcess (knownSuffixHandlers) import Distribution.Simple.SrcDist (listPackageSourcesWithDie) import Distribution.Simple.Utils (dieWithException) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Distribution.Utils.Path + ( getSymbolicPath + , makeSymbolicPath + ) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar @@ -29,7 +33,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Set as Set -import Distribution.Client.Errors +import System.Directory (canonicalizePath) +import System.FilePath -- | List all source files of a given add-source dependency. Exits with error if -- something is wrong (e.g. there is no .cabal file in the given directory). @@ -38,12 +43,17 @@ -- TODO: when sandboxes are removed, move to ProjectBuilding. allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] allPackageSourceFiles verbosity packageDir = do - pd <- do - let err = "Error reading source files of package." - desc <- tryFindAddSourcePackageDesc verbosity packageDir err - flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc - - listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers + let err = "Error reading source files of package." + gpd <- tryReadAddSourcePackageDesc verbosity packageDir err + let pd = flattenPackageDescription gpd + srcs <- + listPackageSourcesWithDie + verbosity + (\_ _ -> return []) + (Just $ makeSymbolicPath packageDir) + pd + knownSuffixHandlers + return $ map getSymbolicPath srcs -- | Create a tarball for a package in a directory packageDirToSdist @@ -57,10 +67,10 @@ packageDirToSdist verbosity gpd dir = do -- let thisDie :: Verbosity -> String -> IO a -- thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s - - files' <- listPackageSourcesWithDie verbosity dieWithException dir (flattenPackageDescription gpd) knownSuffixHandlers + absDir <- canonicalizePath dir + files' <- listPackageSourcesWithDie verbosity dieWithException (Just $ makeSymbolicPath absDir) (flattenPackageDescription gpd) knownSuffixHandlers let files :: [FilePath] - files = nub $ sort $ map normalise files' + files = nub $ 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 @@ -48,10 +48,8 @@ #else import System.IO (openFile, IOMode(ReadWriteMode), hClose) import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) -#if MIN_VERSION_base(4,11,0) import GHC.IO.Handle.Lock (hUnlock) #endif -#endif -- $concurrency -- @@ -217,7 +215,7 @@ -- Atomically rename the temp dir to the final store entry location. renameDirectory incomingEntryDir finalEntryDir for_ otherFiles $ \file -> do - let finalStoreFile = storeDirectory compiler makeRelative (incomingTmpDir (dropDrive (storeDirectory compiler))) file + let finalStoreFile = storeDirectory compiler makeRelative (normalise $ incomingTmpDir (dropDrive (storeDirectory compiler))) file createDirectoryIfMissing True (takeDirectory finalStoreFile) renameFile file finalStoreFile 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 @@ -131,6 +131,8 @@ , ordNub ) import Distribution.Utils.Path + ( getSymbolicPath + ) import qualified System.Directory as IO ( canonicalizePath , doesDirectoryExist @@ -138,18 +140,18 @@ , getCurrentDirectory ) import System.FilePath - ( dropTrailingPathSeparator - , equalFilePath - , normalise - , (<.>) - , () - ) -import System.FilePath as FilePath ( dropExtension + , dropTrailingPathSeparator + , equalFilePath , joinPath + , normalise , splitDirectories - , splitPath + ) +import qualified System.FilePath as FilePath + ( splitPath , takeExtension + , (<.>) + , () ) import Text.EditDistance ( defaultEditCosts @@ -475,7 +477,7 @@ fileStatus f = do fexists <- doesFileExist f dexists <- doesDirectoryExist f - case splitPath f of + case FilePath.splitPath f of _ | fexists -> FileStatusExistsFile <$> canonicalizePath f | dexists -> FileStatusExistsDir <$> canonicalizePath f @@ -923,7 +925,7 @@ let ql = targetQualLevel usertarget in foldSyntax (<|>) - () + () (\ql' match _ -> guard (ql == ql') >> match usertarget) syntax where @@ -1892,8 +1894,8 @@ dirabs <- canonicalizePath dir dirrel <- makeRelativeToCwd dirActions dirabs -- TODO: ought to get this earlier in project reading - let fileabs = dirabs prettyShow (packageName pkg) <.> "cabal" - filerel = dirrel prettyShow (packageName pkg) <.> "cabal" + let fileabs = dirabs FilePath. prettyShow (packageName pkg) FilePath.<.> "cabal" + filerel = dirrel FilePath. prettyShow (packageName pkg) FilePath.<.> "cabal" exists <- doesFileExist fileabs return ( Just (dirabs, dirrel) @@ -1920,8 +1922,8 @@ , cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)) , cinfoModules = ordNub (componentModules c) , cinfoHsFiles = ordNub (componentHsFiles c) - , cinfoCFiles = ordNub (cSources bi) - , cinfoJsFiles = ordNub (jsSources bi) + , cinfoCFiles = ordNub (map getSymbolicPath $ cSources bi) + , cinfoJsFiles = ordNub (map getSymbolicPath $ jsSources bi) } | c <- pkgComponents pkg , let bi = componentBuildInfo c @@ -1945,19 +1947,19 @@ componentModules (CBench bench) = benchmarkModules bench componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CExe exe) = [getSymbolicPath $ modulePath exe] componentHsFiles ( CTest TestSuite { testInterface = TestSuiteExeV10 _ mainfile } - ) = [mainfile] + ) = [getSymbolicPath mainfile] componentHsFiles ( CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainfile } - ) = [mainfile] + ) = [getSymbolicPath mainfile] componentHsFiles _ = [] ------------------------------ @@ -2082,7 +2084,7 @@ guardPackageFile :: String -> FileStatus -> Match () guardPackageFile _ (FileStatusExistsFile file) - | takeExtension file == ".cabal" = + | FilePath.takeExtension file == ".cabal" = increaseConfidence guardPackageFile str _ = matchErrorExpected "package .cabal file" str @@ -2090,10 +2092,10 @@ matchPackage pinfo = \str fstatus -> orNoThingIn "project" "" $ matchPackageName pinfo str - ( matchPackageNameUnknown str + ( matchPackageNameUnknown str <|> matchPackageDir pinfo str fstatus <|> matchPackageFile pinfo str fstatus - ) + ) matchPackageName :: [KnownPackage] -> String -> Match KnownPackage matchPackageName ps = \str -> do @@ -2259,7 +2261,7 @@ -> Match (FilePath, KnownComponent) matchComponentOtherFile cs = matchFile - [ (normalise (srcdir file), c) + [ (normalise (srcdir FilePath. file), c) | c <- cs , srcdir <- cinfoSrcDirs c , file <- @@ -2275,7 +2277,7 @@ -> Match (FilePath, KnownComponent) matchComponentModuleFile cs str = do matchFile - [ (normalise (d toFilePath m), c) + [ (normalise (d FilePath. toFilePath m), c) | c <- cs , d <- cinfoSrcDirs c , m <- cinfoModules c @@ -2389,10 +2391,10 @@ mzero = empty mplus = matchPlus -() :: Match a -> Match a -> Match a -() = matchPlusShadowing +() :: Match a -> Match a -> Match a +() = matchPlusShadowing -infixl 3 +infixl 3 -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the 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 @@ -78,7 +78,7 @@ ( RepoContext (..) ) import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Utils (tryFindPackageDesc) +import Distribution.Client.Utils (tryReadGenericPackageDesc) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint (..) ) @@ -100,15 +100,13 @@ import Distribution.PackageDescription.Parsec ( parseGenericPackageDescriptionMaybe ) -import Distribution.Simple.PackageDescription - ( readGenericPackageDescription - ) import qualified Data.ByteString.Lazy as BS import qualified Data.Map as Map import Distribution.Client.Errors import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Compat.CharParsing as P +import Distribution.Utils.Path (makeSymbolicPath) import Network.URI ( URI (..) , URIAuth (..) @@ -350,7 +348,7 @@ return [PackageTargetLocation (LocalUnpackedPackage dir)] UserTargetLocalCabalFile file -> do let dir = takeDirectory file - _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check + _ <- tryReadGenericPackageDesc verbosity (makeSymbolicPath dir) (localPackageError dir) -- just as a check return [PackageTargetLocation (LocalUnpackedPackage dir)] UserTargetLocalTarball tarballFile -> return [PackageTargetLocation (LocalTarballPackage tarballFile)] @@ -389,9 +387,7 @@ modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage modifyLocation location = case location of LocalUnpackedPackage dir -> do - pkg <- - tryFindPackageDesc verbosity dir (localPackageError dir) - >>= readGenericPackageDescription verbosity + pkg <- tryReadGenericPackageDesc verbosity (makeSymbolicPath dir) (localPackageError dir) return SourcePackage { srcpkgPackageId = packageId pkg 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Client.Utils @@ -7,7 +8,6 @@ , duplicates , duplicatesBy , readMaybe - , inDir , withEnv , withEnvOverrides , logDirChange @@ -19,6 +19,7 @@ , makeAbsoluteToCwd , makeRelativeToCwd , makeRelativeToDir + , makeRelativeToDirS , makeRelativeCanonical , filePathToByteString , byteStringToFilePath @@ -26,8 +27,8 @@ , canonicalizePathNoThrow , moreRecentFile , existsAndIsMoreRecentThan - , tryFindAddSourcePackageDesc - , tryFindPackageDesc + , tryReadAddSourcePackageDesc + , tryReadGenericPackageDesc , relaxEncodingErrors , ProgressPhase (..) , progressMessage @@ -65,20 +66,33 @@ ( elemIndex , groupBy ) +import Distribution.Client.Errors import Distribution.Compat.Environment import Distribution.Compat.Time (getModTime) import Distribution.Simple.Setup (Flag (..)) import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap) +import Distribution.Utils.Path + ( CWD + , FileOrDir (..) + , Pkg + , RelativePath + , SymbolicPath + , getSymbolicPath + , makeSymbolicPath + , relativeSymbolicPath + , sameDirectory + , symbolicPathRelative_maybe + ) import Distribution.Version + import System.Directory ( canonicalizePath , doesDirectoryExist , doesFileExist - , getCurrentDirectory , getDirectoryContents , removeFile - , setCurrentDirectory ) +import qualified System.Directory as Directory import System.FilePath import System.IO ( Handle @@ -107,7 +121,8 @@ import qualified System.IO.Error as IOError #endif import qualified Data.Set as Set -import Distribution.Client.Errors +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] @@ -159,17 +174,6 @@ (\(name, _) -> removeExistingFile name) (\(name, h) -> hClose h >> action name) --- | Executes the action in the specified directory. --- --- Warning: This operation is NOT thread-safe, because current --- working directory is a process-global concept. -inDir :: Maybe FilePath -> IO a -> IO a -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old - -- | Executes the action with an environment variable set to some -- value. -- @@ -249,14 +253,14 @@ makeAbsoluteToCwd path | isAbsolute path = return path | otherwise = do - cwd <- getCurrentDirectory + cwd <- Directory.getCurrentDirectory return $! cwd path -- | Given a path (relative or absolute), make it relative to the current -- directory, including using @../..@ if necessary. makeRelativeToCwd :: FilePath -> IO FilePath makeRelativeToCwd path = - makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + makeRelativeCanonical <$> canonicalizePath path <*> Directory.getCurrentDirectory -- | Given a path (relative or absolute), make it relative to the given -- directory, including using @../..@ if necessary. @@ -264,6 +268,16 @@ makeRelativeToDir path dir = makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir +-- | makeRelativeToDir for SymbolicPath +makeRelativeToDirS :: Maybe (SymbolicPath CWD (Dir dir)) -> SymbolicPath CWD to -> IO (SymbolicPath dir to) +makeRelativeToDirS Nothing s = makeRelativeToDirS (Just sameDirectory) s +makeRelativeToDirS (Just root) p = + case symbolicPathRelative_maybe p of + -- TODO: Use AbsolutePath + Nothing -> return $ makeSymbolicPath (getSymbolicPath p) + Just rel_path -> + makeSymbolicPath <$> makeRelativeToDir (getSymbolicPath root) (getSymbolicPath rel_path) + -- | Given a canonical absolute path and canonical absolute dir, make the path -- relative to the directory, including using @../..@ if necessary. Returns -- the original absolute path if it is not on the same drive as the given dir. @@ -377,20 +391,41 @@ return () -- | Like 'tryFindPackageDesc', but with error specific to add-source deps. -tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath -tryFindAddSourcePackageDesc verbosity depPath err = - tryFindPackageDesc verbosity depPath $ - err - ++ "\n" - ++ "Failed to read cabal file of add-source dependency: " - ++ depPath +tryReadAddSourcePackageDesc + :: Verbosity + -> FilePath + -> String + -> IO GenericPackageDescription +tryReadAddSourcePackageDesc verbosity depPath err = do + let pkgDir = makeSymbolicPath depPath + pkgDescPath <- + try_find_package_desc verbosity pkgDir $ + err + ++ "\n" + ++ "Failed to read cabal file of add-source dependency: " + ++ depPath + readGenericPackageDescription verbosity (Just pkgDir) (relativeSymbolicPath pkgDescPath) --- | Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be +-- | Try to read a @.cabal@ file, in directory @depPath@. Fails if one cannot be -- found, with @err@ prefixing the error message. This function simply allows -- us to give a more descriptive error than that provided by @findPackageDesc@. -tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath -tryFindPackageDesc verbosity depPath err = do - errOrCabalFile <- findPackageDesc depPath +tryReadGenericPackageDesc + :: Verbosity + -> SymbolicPath CWD (Dir Pkg) + -> String + -> IO GenericPackageDescription +tryReadGenericPackageDesc verbosity pkgDir err = do + pkgDescPath <- try_find_package_desc verbosity pkgDir err + readGenericPackageDescription verbosity (Just pkgDir) (relativeSymbolicPath pkgDescPath) + +-- | Internal helper function for 'tryReadAddSourcePackageDesc' and 'tryReadGenericPackageDesc'. +try_find_package_desc + :: Verbosity + -> SymbolicPath CWD (Dir Pkg) + -> String + -> IO (RelativePath Pkg File) +try_find_package_desc verbosity pkgDir err = do + errOrCabalFile <- findPackageDesc (Just pkgDir) case errOrCabalFile of Right file -> return file Left _ -> dieWithException verbosity $ TryFindPackageDescErr err @@ -411,13 +446,20 @@ noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" where phaseStr = case phase of - ProgressDownloading -> "Downloading " - ProgressDownloaded -> "Downloaded " - ProgressStarting -> "Starting " - ProgressBuilding -> "Building " - ProgressHaddock -> "Haddock " - ProgressInstalling -> "Installing " - ProgressCompleted -> "Completed " + ProgressDownloading -> + "Downloading " + ProgressDownloaded -> + "Downloaded " + ProgressStarting -> + "Starting " + ProgressBuilding -> + "Building " + ProgressHaddock -> + "Haddock " + ProgressInstalling -> + "Installing " + ProgressCompleted -> + "Completed " -- | Given a version, return an API-compatible (according to PVP) version range. -- 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 @@ -206,7 +206,7 @@ -> VCS Program -> IO (VCS ConfiguredProgram) configureVCS verbosity progPaths vcs@VCS{vcsProgram = prog} = do - progPath <- prependProgramSearchPath verbosity progPaths emptyProgramDb + progPath <- prependProgramSearchPath verbosity progPaths [] emptyProgramDb asVcsConfigured <$> requireProgram verbosity prog progPath where asVcsConfigured (prog', _) = vcs{vcsProgram = prog'} 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 @@ -121,19 +121,12 @@ pure = ParseOk [] (<*>) = ap -{- FOURMOLU_DISABLE -} instance Monad ParseResult where return = pure ParseFailed err >>= _ = ParseFailed err ParseOk ws x >>= f = case f x of ParseFailed err -> ParseFailed err ParseOk ws' x' -> ParseOk (ws' ++ ws) x' -#if !(MIN_VERSION_base(4,9,0)) - fail = parseResultFail -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif -{- FOURMOLU_ENABLE -} instance Foldable ParseResult where foldMap _ (ParseFailed _) = mempty 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 @@ -119,12 +119,6 @@ (Result x p) >>= k = k x `mplus` (p >>= k) (Final r) >>= k = final [ys' | (x, s) <- r, ys' <- run (k x) s] -#if !(MIN_VERSION_base(4,9,0)) - fail _ = Fail -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - instance Fail.MonadFail (P s) where fail _ = Fail @@ -179,12 +173,6 @@ instance Monad (Parser r s) where return = pure R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) - -#if !(MIN_VERSION_base(4,9,0)) - fail _ = R (const Fail) -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif instance Fail.MonadFail (Parser r s) where fail _ = R (const Fail) diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs --- a/tests/IntegrationTests2.hs +++ b/tests/IntegrationTests2.hs @@ -59,7 +59,7 @@ import Distribution.Version import Distribution.ModuleName (ModuleName) import Distribution.Text -import Distribution.Utils.Path +import Distribution.Utils.Path (unsafeMakeSymbolicPath) import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject import Distribution.Client.Setup (globalStoreDir) import Distribution.Client.GlobalFlags (defaultGlobalFlags) @@ -74,7 +74,9 @@ import Control.Exception hiding (assert) import System.FilePath import System.Directory +import System.Environment (setEnv) import System.IO (hPutStrLn, stderr) +import System.Process (callProcess) import Test.Tasty import Test.Tasty.HUnit @@ -93,7 +95,16 @@ #endif main :: IO () -main = +main = do + -- this is needed to ensure tests aren't affected by the user's cabal config + cwd <- getCurrentDirectory + let configDir = cwd basedir "config" "cabal-config" + setEnv "CABAL_DIR" configDir + removeDirectoryRecursive configDir <|> return () + createDirectoryIfMissing True configDir + -- sigh + callProcess "cabal" ["user-config", "init", "-f"] + callProcess "cabal" ["update"] defaultMainWithIngredients (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions]) (withProjectConfig $ \config -> @@ -488,7 +499,7 @@ withCFiles :: Executable -> [FilePath] -> Executable withCFiles exe files = - exe { buildInfo = (buildInfo exe) { cSources = files } } + exe { buildInfo = (buildInfo exe) { cSources = map unsafeMakeSymbolicPath files } } withHsSrcDirs :: Executable -> [FilePath] -> Executable withHsSrcDirs exe srcDirs = @@ -1971,8 +1982,8 @@ -- Tests whether config options are commented or not testConfigOptionComments :: Assertion testConfigOptionComments = do - _ <- createDefaultConfigFile verbosity [] (basedir "config/default-config") - defaultConfigFile <- readFile (basedir "config/default-config") + _ <- createDefaultConfigFile verbosity [] (basedir "config" "default-config") + defaultConfigFile <- readFile (basedir "config" "default-config") " url" @=? findLineWith False "url" defaultConfigFile " -- secure" @=? findLineWith True "secure" defaultConfigFile @@ -2099,7 +2110,9 @@ " -- contents-location" @=? findLineWith True "contents-location" defaultConfigFile " -- index-location" @=? findLineWith True "index-location" defaultConfigFile " -- base-url" @=? findLineWith True "base-url" defaultConfigFile + " -- resources-dir" @=? findLineWith True "resources-dir" defaultConfigFile " -- output-dir" @=? findLineWith True "output-dir" defaultConfigFile + " -- use-unicode" @=? findLineWith True "use-unicode" defaultConfigFile " -- interactive" @=? findLineWith True "interactive" defaultConfigFile " -- quiet" @=? findLineWith True "quiet" defaultConfigFile 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 @@ -42,7 +42,8 @@ { configFlags = mempty { configOptimization = Flag MaximumOptimisation - , configVerbosity = Flag silent + , configCommonFlags = + mempty{setupVerbosity = Flag silent} } } projConfig <- configureAction' flags [] defaultGlobalFlags @@ -59,7 +60,8 @@ , configFlags = mempty { configOptimization = Flag NoOptimisation - , configVerbosity = Flag silent + , configCommonFlags = + mempty{setupVerbosity = Flag silent} } } (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags @@ -75,7 +77,8 @@ } , configFlags = mempty - { configVerbosity = Flag silent + { configCommonFlags = + mempty{setupVerbosity = Flag silent} } } (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags @@ -87,7 +90,8 @@ defaultTestFlags { configFlags = mempty - { configVerbosity = Flag silent + { configCommonFlags = + mempty{setupVerbosity = Flag silent} } } (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags @@ -99,7 +103,8 @@ defaultTestFlags { configFlags = mempty - { configVerbosity = Flag silent + { configCommonFlags = + mempty{setupVerbosity = Flag silent} } } backup = projectDir "cabal.project.local~" @@ -118,7 +123,8 @@ defaultTestFlags { configFlags = mempty - { configVerbosity = Flag silent + { configCommonFlags = + mempty{setupVerbosity = Flag silent} , configProgramArgs = [("ghc", ghcFlags)] } } 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 @@ -32,7 +32,7 @@ tests mtimeChange = [ testGroup "Structured hashes" - [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13 + [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe1339b9dcfdfe19d 0x9135a5f30da7ca82 , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint fingerprintStateGlob1 fingerprintStateGlob2 , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint fingerprintStateFileSet1 fingerprintStateFileSet2 ] @@ -88,17 +88,10 @@ Windows -> expectFailBecause msg _ -> id fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64 -#if MIN_VERSION_base(4,19,0) - fingerprintStateGlob1 = 0x4ebc6a7d12bb2132 - fingerprintStateGlob2 = 0x2c2292eeda0a9319 - fingerprintStateFileSet1 = 0x01df5796f9030851 - fingerprintStateFileSet2 = 0x2f5c472be17bee98 -#else - fingerprintStateGlob1 = 0xf32c0d1644dd9ee5 - fingerprintStateGlob2 = 0x0f2494f7b6031fb6 - fingerprintStateFileSet1 = 0x06d4a13275c24282 - fingerprintStateFileSet2 = 0x791b2a88684b5f37 -#endif + fingerprintStateGlob1 = 0x1f9edda22b7e8de6 + fingerprintStateGlob2 = 0xda1d085c9fc6f5db + fingerprintStateFileSet1 = 0x00ac4a0df546905d + fingerprintStateFileSet2 = 0x5b2b2df018b1fa83 -- Check the file system behaves the way we expect it to 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 @@ -17,6 +17,7 @@ import Distribution.Client.Init.Types import Distribution.Client.Sandbox import Distribution.Client.Setup +import Distribution.Simple.Compiler import Distribution.Verbosity tests :: IO [TestTree] @@ -32,7 +33,7 @@ withRepoContext v globalFlags' $ \repoCtx -> do let pkgDb = configPackageDB' confFlags' - pkgIx <- getInstalledPackages v comp pkgDb progdb + pkgIx <- getInstalledPackages v comp (interpretPackageDBStack Nothing pkgDb) progdb srcDb <- getSourcePackages v repoCtx return 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 @@ -81,7 +81,7 @@ "False" ] - case flip _runPrompt inputs $ do + case flip runPrompt inputs $ do projSettings <- createProject comp silent pkgIx srcDb dummyFlags' writeProject projSettings of Left (BreakException ex) -> assertFailure $ show ex 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 @@ -105,7 +105,7 @@ ] where runPkgDesc opts flags args = do - case _runPrompt (genPkgDescription flags srcDb) args of + case runPrompt (genPkgDescription flags srcDb) args of Left e -> assertFailure $ show e Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg @@ -146,7 +146,7 @@ ] where runGoldenExe opts args flags = - case _runPrompt (genExeTarget flags pkgIx) args of + case runPrompt (genExeTarget flags pkgIx) args of Right (t, _) -> mkStanza [mkExeStanza opts $ t{_exeDependencies = mangleBaseDep t _exeDependencies}] Left e -> assertFailure $ show e @@ -192,7 +192,7 @@ ] where runGoldenLib opts args flags = - case _runPrompt (genLibTarget flags pkgIx) args of + case runPrompt (genLibTarget flags pkgIx) args of Right (t, _) -> mkStanza [mkLibStanza opts $ t{_libDependencies = mangleBaseDep t _libDependencies}] Left e -> assertFailure $ show e @@ -243,7 +243,7 @@ ] where runGoldenTest opts args flags = - case _runPrompt (genTestTarget flags pkgIx) args of + case runPrompt (genTestTarget flags pkgIx) args of Left e -> assertFailure $ show e Right (Nothing, _) -> assertFailure @@ -286,7 +286,7 @@ ] where runGoldenTest args flags = - case _runPrompt (createProject v pkgIx srcDb flags) args of + case runPrompt (createProject v pkgIx srcDb flags) args of Left e -> assertFailure $ show e (Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do let pkgFields = mkPkgDescription opts pkgDesc 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 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 @@ -186,7 +186,7 @@ "y" ] - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -286,7 +286,7 @@ "y" ] - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -372,7 +372,7 @@ "y" ] - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -460,7 +460,7 @@ "y" ] - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -546,7 +546,7 @@ "y" ] - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -631,7 +631,7 @@ , extraSrc = Flag ["README.md"] } - case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb flags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -709,7 +709,7 @@ "y" ] - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -809,7 +809,7 @@ ] ] where - runGenTest inputs go = case _runPrompt go inputs of + runGenTest inputs go = case runPrompt go inputs of Left e -> assertFailure $ show e Right{} -> return () @@ -1031,6 +1031,20 @@ ] ] , testGroup + "Check languagePrompt session state" + [ testSimplePrompt + "Use last language" + ( \flags -> do + a <- languagePrompt flags "first language" + b <- languagePrompt flags "second language" + pure (a, b) + ) + (GHC2024, GHC2024) + [ "4" + , "" -- default + ] + ] + , testGroup "Check srcDirsPrompt output" [ testNumberedPrompt "Source dirs indices" @@ -1113,7 +1127,7 @@ -> [String] -> TestTree testPrompt label f g h input = testCase label $ - case (_runPrompt $ f emptyFlags) (fromList input) of + case (runPrompt $ f emptyFlags) (fromList input) of Left x -> g x -- :: BreakException Right x -> h x -- :: (a, other inputs) 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 @@ -93,7 +93,7 @@ , "[\"quxTest/Main.hs\"]" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of + case (runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -180,7 +180,7 @@ "False" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of + case (runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -356,7 +356,7 @@ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" ] - case ( _runPrompt $ + case ( runPrompt $ createProject comp silent @@ -508,7 +508,7 @@ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" ] - case ( _runPrompt $ + case ( runPrompt $ createProject comp silent @@ -664,7 +664,7 @@ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -774,7 +774,7 @@ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -865,7 +865,7 @@ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -931,7 +931,7 @@ , "[]" ] - case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of + case (runPrompt $ genPkgDescription emptyFlags srcDb) inputs of Left e -> assertFailure $ show e Right{} -> return () ] @@ -980,7 +980,7 @@ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of + case (runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of Left e -> assertFailure $ show e Right{} -> return () ] @@ -1021,7 +1021,7 @@ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of + case (runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of Left e -> assertFailure $ show e Right{} -> return () ] @@ -1058,7 +1058,7 @@ ] flags = emptyFlags{initializeTestSuite = Flag True} - case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of + case (runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of Left e -> assertFailure $ show e Right{} -> return () ] @@ -1403,7 +1403,7 @@ -> [String] -> TestTree testGo label f g h inputs = testCase label $ - case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of + case (runPrompt $ f emptyFlags) (NEL.fromList inputs) of Left x -> g x Right x -> h x 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 @@ -69,7 +69,7 @@ Nothing Nothing - case _runPrompt (createProject v pkgIx srcDb flags) inputs of + case runPrompt (createProject v pkgIx srcDb flags) inputs of Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e Right (settings', _) -> settings @=? settings' , testCase "Simple lib createProject - with tests" $ do @@ -83,7 +83,7 @@ Nothing (Just $ simpleTestTarget (Just pkgName) baseDep) - case _runPrompt (createProject v pkgIx srcDb flags) inputs of + case runPrompt (createProject v pkgIx srcDb flags) inputs of Left e -> assertFailure $ "Failed to create simple lib (with tests)project: " ++ show e Right (settings', _) -> settings @=? settings' , testCase "Simple exe createProject" $ do @@ -97,7 +97,7 @@ (Just $ simpleExeTarget Nothing baseDep) Nothing - case _runPrompt (createProject v pkgIx srcDb flags) inputs of + case runPrompt (createProject v pkgIx srcDb flags) inputs of Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e Right (settings', _) -> settings @=? settings' , testCase "Simple lib+exe createProject - no tests" $ do @@ -111,7 +111,7 @@ (Just $ simpleExeTarget (Just pkgName) baseDep) Nothing - case _runPrompt (createProject v pkgIx srcDb flags) inputs of + case runPrompt (createProject v pkgIx srcDb flags) inputs of Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e Right (settings', _) -> settings @=? settings' , testCase "Simple lib+exe createProject - with tests" $ do @@ -125,7 +125,7 @@ (Just $ simpleExeTarget (Just pkgName) baseDep) (Just $ simpleTestTarget (Just pkgName) baseDep) - case _runPrompt (createProject v pkgIx srcDb flags) inputs of + case runPrompt (createProject v pkgIx srcDb flags) inputs of Left e -> assertFailure $ "Failed to create simple lib+exe (with tests) project: " ++ show e Right (settings', _) -> settings @=? settings' , testCase "Simple standalone tests" $ do @@ -139,12 +139,12 @@ Nothing (Just $ simpleTestTarget Nothing baseDep) - case _runPrompt (createProject v pkgIx srcDb flags) inputs of + case runPrompt (createProject v pkgIx srcDb flags) inputs of Left e -> assertFailure $ "Failed to create simple standalone test project: " ++ show e Right (settings', _) -> settings @=? settings' ] where - baseDep = case _runPrompt (getBaseDep pkgIx emptyFlags) $ fromList [] of + baseDep = case runPrompt (getBaseDep pkgIx emptyFlags) $ fromList [] of Left e -> error $ show e Right a -> fst a 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 @@ -10,10 +10,6 @@ module UnitTests.Distribution.Client.ProjectConfig (tests) where -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -import Control.Applicative -#endif import Control.Monad import Data.Either (isRight) import Data.Foldable (for_) @@ -102,6 +98,7 @@ , testProperty "specific" prop_roundtrip_printparse_specific , testProperty "all" prop_roundtrip_printparse_all ] + , testGetProjectRootUsability , testFindProjectRoot ] where @@ -110,6 +107,31 @@ CompilerId GHC v -> v < mkVersion [7, 7] _ -> False +testGetProjectRootUsability :: TestTree +testGetProjectRootUsability = + testGroup + "getProjectRootUsability" + [ test "relative path" file ProjectRootUsabilityPresentAndUsable + , test "absolute path" absFile ProjectRootUsabilityPresentAndUsable + , test "symbolic link" fileSymlink ProjectRootUsabilityPresentAndUsable + , test "file not present" fileNotPresent ProjectRootUsabilityNotPresent + , test "directory" brokenDirCabalProject ProjectRootUsabilityPresentAndUnusable + , test "broken symbolic link" fileSymlinkBroken ProjectRootUsabilityPresentAndUnusable + ] + where + dir = fixturesDir "project-root" + file = defaultProjectFile + absFile = dir file + fileNotPresent = file <.> "not-present" + fileSymlink = file <.> "symlink" + fileSymlinkBroken = fileSymlink <.> "broken" + brokenDirCabalProject = "cabal" <.> "project" <.> "dir" <.> "broken" + test name fileName expectedState = + testCase name $ + withCurrentDirectory dir $ + getProjectRootUsability fileName + >>= (@?= expectedState) + testFindProjectRoot :: TestTree testFindProjectRoot = testGroup @@ -120,6 +142,10 @@ , test "explicit file in lib" (cd libDir) Nothing (Just file) (succeeds dir file) , test "other file" (cd dir) Nothing (Just fileOther) (succeeds dir fileOther) , test "other file in lib" (cd libDir) Nothing (Just fileOther) (succeeds dir fileOther) + , test "symbolic link" (cd dir) Nothing (Just fileSymlink) (succeeds dir fileSymlink) + , test "symbolic link in lib" (cd libDir) Nothing (Just fileSymlink) (succeeds dir fileSymlink) + , test "broken symbolic link" (cd dir) Nothing (Just fileSymlinkBroken) (failsWith $ BadProjectRootFileBroken fileSymlinkBroken) + , test "broken symbolic link in lib" (cd libDir) Nothing (Just fileSymlinkBroken) (failsWith $ BadProjectRootFileBroken fileSymlinkBroken) , -- Deprecated use-case test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file) , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile) @@ -141,6 +167,9 @@ nixFile = "nix" file nixOther = nixFile <.> "other" + fileSymlink = file <.> "symlink" + fileSymlinkBroken = fileSymlink <.> "broken" + missing path = Just (path <.> "does_not_exist") test name wrap projectDir projectFile validate = @@ -169,6 +198,18 @@ Left _ -> pure () Right x -> assertFailure $ "Expected an error, but found " <> show x + failsWith expectedError result = case result of + Left actualError -> + if actualError == expectedError + then pure () + else + assertFailure $ + "Expected an error " + <> show expectedError + <> ", but found " + <> show actualError + Right x -> assertFailure $ "Expected an error, but found " <> show x + fixturesDir :: FilePath fixturesDir = unsafePerformIO $ @@ -683,6 +724,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> shortListOf 5 arbitraryShortToken <*> arbitrary <*> arbitrary @@ -726,6 +768,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> shortListOf 5 arbitrary @@ -751,6 +794,7 @@ , packageConfigFullyStaticExe = x50 , packageConfigProf = x07 , packageConfigProfLib = x08 + , packageConfigProfShared = x08_1 , packageConfigProfExe = x09 , packageConfigProfDetail = x10 , packageConfigProfLibDetail = x11 @@ -791,8 +835,9 @@ , packageConfigHaddockForHackage = x41 , packageConfigHaddockIndex = x54 , packageConfigHaddockBaseUrl = x55 - , packageConfigHaddockLib = x56 + , packageConfigHaddockResourcesDir = x56 , packageConfigHaddockOutputDir = x57 + , packageConfigHaddockUseUnicode = x58 , packageConfigTestHumanLog = x44 , packageConfigTestMachineLog = x45 , packageConfigTestShowDetails = x46 @@ -814,6 +859,7 @@ , packageConfigFullyStaticExe = x50' , packageConfigProf = x07' , packageConfigProfLib = x08' + , packageConfigProfShared = x08_1' , packageConfigProfExe = x09' , packageConfigProfDetail = x10' , packageConfigProfLibDetail = x11' @@ -854,8 +900,9 @@ , packageConfigHaddockForHackage = x41' , packageConfigHaddockIndex = x54' , packageConfigHaddockBaseUrl = x55' - , packageConfigHaddockLib = x56' + , packageConfigHaddockResourcesDir = x56' , packageConfigHaddockOutputDir = x57' + , packageConfigHaddockUseUnicode = x58' , packageConfigTestHumanLog = x44' , packageConfigTestMachineLog = x45' , packageConfigTestShowDetails = x46' @@ -866,7 +913,7 @@ , packageConfigBenchmarkOptions = x52' } | ( ( (x00', x01', x02', x03', x04') - , (x05', x42', x06', x50', x07', x08', x09') + , (x05', x42', x06', x50', x07', x08', x08_1', x09') , (x10', x11', x12', x13', x14') , (x15', x16', x53', x17', x18', x19') ) @@ -878,12 +925,13 @@ , (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55') , x56' , x57' + , x58' ) ) <- shrink ( ( (preShrink_Paths x00, preShrink_Args x01, x02, x03, x04) - , (x05, x42, x06, x50, x07, x08, x09) + , (x05, x42, x06, x50, x07, x08, x08_1, x09) , (x10, x11, map NonEmpty x12, x13, x14) , ( x15 @@ -903,6 +951,7 @@ , (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55) , x56 , x57 + , x58 ) ) ] 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -21,7 +22,7 @@ import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage) -import Distribution.Simple.Compiler (PackageDB) +import Distribution.Simple.Compiler (PackageDBX) import Data.TreeDiff.Class import Data.TreeDiff.Instances.Cabal () @@ -54,7 +55,7 @@ instance ToExpr Outcome instance ToExpr OverwritePolicy instance ToExpr PackageConfig -instance ToExpr PackageDB +instance ToExpr (PackageDBX FilePath) instance ToExpr PackageProperty instance ToExpr PreferOldest instance ToExpr PreSolver 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 @@ -7,9 +7,6 @@ import Control.Exception (bracket) import Control.Monad (replicateM_) import Data.List (nub, sort) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif import System.Directory ( doesFileExist , getCurrentDirectory 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 @@ -449,7 +449,7 @@ , C.maintainer = "maintainer" , C.description = "description" , C.synopsis = "synopsis" - , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"] + , C.licenseFiles = [C.makeRelativePathEx "LICENSE"] , -- Version 2.0 is required for internal libraries. C.specVersion = C.CabalSpecV2_0 } @@ -524,21 +524,25 @@ defaultExe = mempty { C.buildInfo = defaultTopLevelBuildInfo - , C.modulePath = "Main.hs" + , C.modulePath = C.makeRelativePathEx "Main.hs" } defaultTest :: C.TestSuite defaultTest = mempty { C.testBuildInfo = defaultTopLevelBuildInfo - , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1, 0]) "Test.hs" + , C.testInterface = + C.TestSuiteExeV10 (C.mkVersion [1, 0]) $ + C.makeRelativePathEx "Test.hs" } defaultBenchmark :: C.Benchmark defaultBenchmark = mempty { C.benchmarkBuildInfo = defaultTopLevelBuildInfo - , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1, 0]) "Benchmark.hs" + , C.benchmarkInterface = + C.BenchmarkExeV10 (C.mkVersion [1, 0]) $ + C.makeRelativePathEx "Benchmark.hs" } -- Split the set of dependencies into the set of dependencies of the library, @@ -779,7 +783,7 @@ -> Maybe [Extension] -- List of languages supported by the compiler, or Nothing if unknown. -> Maybe [Language] - -> PC.PkgConfigDb + -> Maybe PC.PkgConfigDb -> [ExamplePkgName] -> Maybe Int -> CountConflicts 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 @@ -130,7 +130,7 @@ , testDb :: ExampleDb , testSupportedExts :: Maybe [Extension] , testSupportedLangs :: Maybe [Language] - , testPkgConfigDb :: PkgConfigDb + , testPkgConfigDb :: Maybe PkgConfigDb , testEnableAllTests :: EnableAllTests } @@ -233,7 +233,7 @@ , testDb = db , testSupportedExts = exts , testSupportedLangs = langs - , testPkgConfigDb = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb + , testPkgConfigDb = pkgConfigDbFromList <$> mPkgConfigDb , testEnableAllTests = EnableAllTests False } 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 @@ -10,7 +10,6 @@ import Control.Arrow ((&&&)) import Data.Either (lefts) -import Data.Hashable (Hashable (..)) import Data.List (groupBy, isInfixOf) import Text.Show.Pretty (parseValue, valToStr) @@ -20,7 +19,7 @@ import Test.Tasty (TestTree) import Distribution.Types.Flag (FlagName) -import Distribution.Utils.ShortText (ShortText) +import Distribution.Utils.ShortText (ShortText, fromShortText) import Distribution.Client.Setup (defaultMaxBackjumps) @@ -47,12 +46,26 @@ import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - ( testPropertyWithSeed + ( ArbitraryOrd (..) + , testPropertyWithSeed ) tests :: [TestTree] tests = - [ -- This test checks that certain solver parameters do not affect the + [ testPropertyWithSeed "solver does not throw exceptions" $ + \test goalOrder reorderGoals indepGoals prefOldest -> + let r = + solve + (EnableBackjumping True) + (FineGrainedConflicts True) + reorderGoals + (CountConflicts True) + indepGoals + prefOldest + (getBlind <$> goalOrder) + test + in resultPlan r `seq` () + , -- This test checks that certain solver parameters do not affect the -- existence of a solution. It runs the solver twice, and only sets those -- parameters on the second run. The test also applies parameters that -- can affect the existence of a solution to both runs. @@ -210,6 +223,9 @@ { unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering } +instance Arbitrary VarOrdering where + arbitrary = VarOrdering <$> arbitraryCompare + solve :: EnableBackjumping -> FineGrainedConflicts @@ -227,7 +243,7 @@ (unTestDb (testDb test)) Nothing Nothing - (pkgConfigDbFromList []) + (Just $ pkgConfigDbFromList []) (map unPN (testTargets test)) -- The backjump limit prevents individual tests from using -- too much time and memory. @@ -516,6 +532,11 @@ shrink (IndependentGoals indep) = [IndependentGoals False | indep] +instance Arbitrary PreferOldest where + arbitrary = PreferOldest <$> arbitrary + + shrink (PreferOldest prefOldest) = [PreferOldest False | prefOldest] + instance Arbitrary Component where arbitrary = oneof @@ -600,22 +621,18 @@ shrink BenchStanzas = [TestStanzas] shrink TestStanzas = [] --- Randomly sorts solver variables using 'hash'. --- TODO: Sorting goals with this function is very slow. -instance Arbitrary VarOrdering where - arbitrary = do - f <- arbitrary :: Gen (Int -> Int) - return $ VarOrdering (comparing (f . hash)) - -instance Hashable pn => Hashable (Variable pn) -instance Hashable a => Hashable (P.Qualified a) -instance Hashable P.PackagePath -instance Hashable P.Qualifier -instance Hashable P.Namespace -instance Hashable OptionalStanza -instance Hashable FlagName -instance Hashable PackageName -instance Hashable ShortText +instance ArbitraryOrd pn => ArbitraryOrd (Variable pn) +instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a) +instance ArbitraryOrd P.PackagePath +instance ArbitraryOrd P.Qualifier +instance ArbitraryOrd P.Namespace +instance ArbitraryOrd OptionalStanza +instance ArbitraryOrd FlagName +instance ArbitraryOrd PackageName +instance ArbitraryOrd ShortText where + arbitraryCompare = do + strc <- arbitraryCompare + pure $ \l r -> strc (fromShortText l) (fromShortText r) deriving instance Generic (Variable pn) deriving instance Generic (P.Qualified a) 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 @@ -1,10 +1,17 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( testPropertyWithSeed + , ArbitraryOrd (..) ) where import Data.Tagged (Tagged, retag) +import GHC.Generics import System.Random (getStdRandom, random) +import qualified Test.QuickCheck as QC import Test.Tasty (TestTree) import Test.Tasty.Options (OptionDescription, lookupOption, setOption) import Test.Tasty.Providers (IsTest (..), singleTest) @@ -31,7 +38,83 @@ run options (QCWithSeed test) progress = do replay <- case lookupOption options of - QuickCheckReplay (Just override) -> return override - QuickCheckReplay Nothing -> getStdRandom random + QuickCheckReplayLegacy override -> return override + _ -> getStdRandom random notice normal $ "Using --quickcheck-replay=" ++ show replay - run (setOption (QuickCheckReplay (Just replay)) options) test progress + run (setOption (QuickCheckReplayLegacy replay) options) test progress + +-- | Typeclass for doing arbitrary (but law-abiding) comparisons. See also +-- 'ArbitraryOrd', this is the version that works with 'GHC.Generics'. +class GArbitraryOrd f where + garbitraryCompare :: QC.Gen (f p -> f p -> Ordering) + +instance GArbitraryOrd V1 where + garbitraryCompare = pure $ \_ _ -> EQ + +instance GArbitraryOrd U1 where + garbitraryCompare = pure $ \_ _ -> EQ + +instance (GArbitraryOrd f, GArbitraryOrd g) => GArbitraryOrd (f :+: g) where + garbitraryCompare = do + bias <- QC.arbitrary + lcompare <- garbitraryCompare + rcompare <- garbitraryCompare + pure $ \l r -> + let args = if bias then (l, r) else (r, l) + in case args of + (L1 x, L1 y) -> lcompare x y + (L1 _, R1 _) -> LT + (R1 x, R1 y) -> rcompare x y + (R1 _, L1 _) -> GT + +instance (GArbitraryOrd f, GArbitraryOrd g) => GArbitraryOrd (f :*: g) where + garbitraryCompare = do + bias <- QC.arbitrary + xcompare <- garbitraryCompare + ycompare <- garbitraryCompare + pure $ \l r -> + let (x1 :*: y1, x2 :*: y2) = if bias then (l, r) else (r, l) + in case xcompare x1 x2 of + LT -> LT + EQ -> ycompare y1 y2 + GT -> GT + +instance GArbitraryOrd f => GArbitraryOrd (M1 i t f) where + garbitraryCompare = (\c (M1 l) (M1 r) -> c l r) <$> garbitraryCompare + +instance ArbitraryOrd c => GArbitraryOrd (K1 i c) where + garbitraryCompare = (\c (K1 l) (K1 r) -> c l r) <$> arbitraryCompare + +-- | Typeclass for doing arbitrary (but law-abiding) comparisons. +class ArbitraryOrd a where + arbitraryCompare :: QC.Gen (a -> a -> Ordering) + default arbitraryCompare + :: (Generic a, GArbitraryOrd (Rep a)) => QC.Gen (a -> a -> Ordering) + arbitraryCompare = (\c l r -> c (from l) (from r)) <$> garbitraryCompare + +instance ArbitraryOrd Char where + arbitraryCompare = arbitraryCompareReverseSection + +-- | Construct an arbitrary comparison by (conceptually) laying out all values +-- in a list, picking two values (since we are using arbitrary these should +-- be "good" values), and then reversing the section between these two values. +arbitraryCompareReverseSection + :: (QC.Arbitrary a, Ord a) => QC.Gen (a -> a -> Ordering) +arbitraryCompareReverseSection = do + x <- QC.arbitrary + y <- QC.arbitrary + let inside n = n >= min x y && n <= max x y + pure $ \l r -> if inside l && inside r then compare r l else compare l r + +instance ArbitraryOrd a => ArbitraryOrd [a] where + arbitraryCompare = do + shorterIsLess <- QC.arbitrary + cmp <- arbitraryCompare + let go [] [] = EQ + go [] (_ : _) = if shorterIsLess then LT else GT + go (_ : _) [] = if shorterIsLess then GT else LT + go (x : xs) (y : ys) = case cmp x y of + LT -> LT + EQ -> go xs ys + GT -> GT + pure go diff --git a/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs b/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs --- a/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs +++ b/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs @@ -10,10 +10,6 @@ import Test.Tasty import Test.Tasty.QuickCheck -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif - tests :: [TestTree] tests = [ testProperty "fromList . toList = id" $ \xs ->